Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2013 Pablo Marchant & The MESA Team
4 : !
5 : ! This program is free software: you can redistribute it and/or modify
6 : ! it under the terms of the GNU Lesser General Public License
7 : ! as published by the Free Software Foundation,
8 : ! either version 3 of the License, or (at your option) any later version.
9 : !
10 : ! This program is distributed in the hope that it will be useful,
11 : ! but WITHOUT ANY WARRANTY; without even the implied warranty of
12 : ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13 : ! See the GNU Lesser General Public License for more details.
14 : !
15 : ! You should have received a copy of the GNU Lesser General Public License
16 : ! along with this program. If not, see <https://www.gnu.org/licenses/>.
17 : !
18 : ! ***********************************************************************
19 :
20 : module binary_job_ctrls_io
21 :
22 : use const_def, only: dp
23 : use binary_def
24 :
25 : implicit none
26 :
27 : include "binary_job_controls.inc"
28 :
29 : namelist /binary_job/ &
30 : show_binary_log_description_at_start, &
31 : binary_history_columns_file, &
32 : warn_binary_extra, &
33 : inlist_names, &
34 : ! extra files (Maybe overkill with so few inlist parameters)
35 : read_extra_binary_job_inlist, extra_binary_job_inlist_name, &
36 : evolve_both_stars, &
37 : relax_primary_to_th_eq, &
38 : log_Lnuc_div_L_for_relax_primary_to_th_eq, &
39 : min_age_for_relax_primary_to_th_eq, &
40 : max_steps_for_relax_primary_to_th_eq, &
41 : no_history_during_relax_primary_to_th_eq, &
42 : reset_age_for_relax_primary_to_th_eq, &
43 : tsync_for_relax_primary_to_th_eq, &
44 : change_ignore_rlof_flag, &
45 : change_initial_ignore_rlof_flag, &
46 : new_ignore_rlof_flag, &
47 : change_model_twins_flag, &
48 : change_initial_model_twins_flag, &
49 : new_model_twins_flag, &
50 : change_point_mass_i, &
51 : change_initial_point_mass_i, &
52 : new_point_mass_i, &
53 : change_m1, &
54 : change_initial_m1, &
55 : new_m1, &
56 : change_m2, &
57 : change_initial_m2, &
58 : new_m2, &
59 : change_separation_eccentricity, &
60 : change_initial_separation_eccentricity, &
61 : change_period_eccentricity, &
62 : change_initial_period_eccentricity, &
63 : new_separation, &
64 : new_period, &
65 : new_eccentricity, &
66 : pgbinary_flag
67 :
68 : contains
69 :
70 :
71 0 : subroutine do_read_binary_job(b, filename, ierr)
72 : use utils_lib
73 : type (binary_info), pointer :: b
74 : character(*), intent(in) :: filename
75 : integer, intent(out) :: ierr
76 : character (len=strlen) :: binary_job_namelist_name
77 : binary_job_namelist_name = ''
78 0 : ierr = 0
79 0 : call set_default_binary_job_controls
80 0 : call read_binary_job_file(b, filename, 1, ierr)
81 0 : end subroutine do_read_binary_job
82 :
83 :
84 0 : recursive subroutine read_binary_job_file(b, filename, level, ierr)
85 : use utils_lib
86 : character(*), intent(in) :: filename
87 : type (binary_info), pointer :: b
88 : integer, intent(in) :: level
89 : integer, intent(out) :: ierr
90 : logical, dimension(max_extra_inlists) :: read_extra
91 : character (len=strlen), dimension(max_extra_inlists) :: extra
92 : integer :: unit, i
93 :
94 0 : ierr = 0
95 :
96 0 : if (level >= 10) then
97 0 : write(*,*) 'ERROR: too many levels of nested extra binary_job inlist files'
98 0 : ierr = -1
99 0 : return
100 : end if
101 :
102 0 : if (len_trim(filename) > 0) then
103 0 : open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr)
104 0 : if (ierr /= 0) then
105 0 : write(*, *) 'Failed to open control namelist file ', trim(filename)
106 0 : return
107 : end if
108 0 : read(unit, nml=binary_job, iostat=ierr)
109 0 : close(unit)
110 0 : if (ierr /= 0) then
111 0 : write(*, *)
112 0 : write(*, *)
113 0 : write(*, *)
114 0 : write(*, *)
115 : write(*, '(a)') &
116 0 : 'Failed while trying to read control namelist file: ' // trim(filename)
117 : write(*, '(a)') &
118 0 : 'Perhaps the following runtime error message will help you find the problem.'
119 0 : write(*, *)
120 0 : open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr)
121 0 : read(unit, nml=binary_job)
122 0 : close(unit)
123 0 : return
124 : end if
125 : end if
126 :
127 0 : call store_binary_job_controls(b, ierr)
128 :
129 : ! recursive calls to read other inlists
130 0 : do i=1, max_extra_inlists
131 0 : read_extra(i) = read_extra_binary_job_inlist(i)
132 0 : read_extra_binary_job_inlist(i) = .false.
133 0 : extra(i) = extra_binary_job_inlist_name(i)
134 0 : extra_binary_job_inlist_name(i) = 'undefined'
135 :
136 0 : if (read_extra(i)) then
137 0 : call read_binary_job_file(b, extra(i), level+1, ierr)
138 0 : if (ierr /= 0) return
139 : end if
140 : end do
141 :
142 : end subroutine read_binary_job_file
143 :
144 :
145 0 : subroutine store_binary_job_controls(b, ierr)
146 : type (binary_info), pointer :: b
147 : integer, intent(out) :: ierr
148 :
149 0 : ierr = 0
150 :
151 0 : b% job% show_binary_log_description_at_start = show_binary_log_description_at_start
152 0 : b% job% binary_history_columns_file = binary_history_columns_file
153 0 : b% job% warn_binary_extra = warn_binary_extra
154 0 : b% job% inlist_names(:) = inlist_names(:)
155 :
156 0 : b% job% evolve_both_stars = evolve_both_stars
157 0 : b% job% relax_primary_to_th_eq = relax_primary_to_th_eq
158 0 : b% job% log_Lnuc_div_L_for_relax_primary_to_th_eq = log_Lnuc_div_L_for_relax_primary_to_th_eq
159 0 : b% job% min_age_for_relax_primary_to_th_eq = min_age_for_relax_primary_to_th_eq
160 0 : b% job% max_steps_for_relax_primary_to_th_eq = max_steps_for_relax_primary_to_th_eq
161 0 : b% job% no_history_during_relax_primary_to_th_eq = no_history_during_relax_primary_to_th_eq
162 0 : b% job% reset_age_for_relax_primary_to_th_eq = reset_age_for_relax_primary_to_th_eq
163 0 : b% job% tsync_for_relax_primary_to_th_eq = tsync_for_relax_primary_to_th_eq
164 :
165 0 : b% job% change_ignore_rlof_flag = change_ignore_rlof_flag
166 0 : b% job% change_initial_ignore_rlof_flag = change_initial_ignore_rlof_flag
167 0 : b% job% new_ignore_rlof_flag = new_ignore_rlof_flag
168 0 : b% job% change_model_twins_flag = change_model_twins_flag
169 0 : b% job% change_initial_model_twins_flag = change_initial_model_twins_flag
170 0 : b% job% new_model_twins_flag = new_model_twins_flag
171 0 : b% job% change_point_mass_i = change_point_mass_i
172 0 : b% job% change_initial_point_mass_i = change_initial_point_mass_i
173 0 : b% job% new_point_mass_i = new_point_mass_i
174 0 : b% job% change_m1 = change_m1
175 0 : b% job% change_initial_m1 = change_initial_m1
176 0 : b% job% new_m1 = new_m1
177 0 : b% job% change_m2 = change_m2
178 0 : b% job% change_initial_m2 = change_initial_m2
179 0 : b% job% new_m2 = new_m2
180 0 : b% job% change_separation_eccentricity = change_separation_eccentricity
181 0 : b% job% change_initial_separation_eccentricity = change_initial_separation_eccentricity
182 0 : b% job% change_period_eccentricity = change_period_eccentricity
183 0 : b% job% change_initial_period_eccentricity = change_initial_period_eccentricity
184 0 : b% job% new_separation = new_separation
185 0 : b% job% new_period = new_period
186 0 : b% job% new_eccentricity = new_eccentricity
187 0 : b% job% pgbinary_flag = pgbinary_flag
188 :
189 0 : end subroutine store_binary_job_controls
190 :
191 :
192 0 : subroutine set_default_binary_job_controls
193 : include 'binary_job.defaults'
194 0 : end subroutine set_default_binary_job_controls
195 :
196 :
197 0 : subroutine set_binary_job_controls_for_writing(b, ierr)
198 : type (binary_info), pointer :: b
199 : integer, intent(out) :: ierr
200 :
201 0 : ierr = 0
202 :
203 0 : show_binary_log_description_at_start = b% job% show_binary_log_description_at_start
204 0 : binary_history_columns_file = b% job% binary_history_columns_file
205 0 : warn_binary_extra = b% job% warn_binary_extra
206 0 : inlist_names(:) = b% job% inlist_names(:)
207 :
208 0 : evolve_both_stars = b% job% evolve_both_stars
209 0 : evolve_both_stars = b% job% evolve_both_stars
210 0 : relax_primary_to_th_eq = b% job% relax_primary_to_th_eq
211 0 : log_Lnuc_div_L_for_relax_primary_to_th_eq = b% job% log_Lnuc_div_L_for_relax_primary_to_th_eq
212 0 : min_age_for_relax_primary_to_th_eq = b% job% min_age_for_relax_primary_to_th_eq
213 0 : max_steps_for_relax_primary_to_th_eq = b% job% max_steps_for_relax_primary_to_th_eq
214 0 : no_history_during_relax_primary_to_th_eq = b% job% no_history_during_relax_primary_to_th_eq
215 0 : reset_age_for_relax_primary_to_th_eq = b% job% reset_age_for_relax_primary_to_th_eq
216 0 : tsync_for_relax_primary_to_th_eq = b% job% tsync_for_relax_primary_to_th_eq
217 :
218 0 : change_ignore_rlof_flag = b% job% change_ignore_rlof_flag
219 0 : change_initial_ignore_rlof_flag = b% job% change_initial_ignore_rlof_flag
220 0 : new_ignore_rlof_flag = b% job% new_ignore_rlof_flag
221 0 : change_model_twins_flag = b% job% change_model_twins_flag
222 0 : change_initial_model_twins_flag = b% job% change_initial_model_twins_flag
223 0 : new_model_twins_flag = b% job% new_model_twins_flag
224 0 : change_point_mass_i = b% job% change_point_mass_i
225 0 : change_initial_point_mass_i = b% job% change_initial_point_mass_i
226 0 : new_point_mass_i = b% job% new_point_mass_i
227 0 : change_m1 = b% job% change_m1
228 0 : change_initial_m1 = b% job% change_initial_m1
229 0 : new_m1 = b% job% new_m1
230 0 : change_m2 = b% job% change_m2
231 0 : change_initial_m2 = b% job% change_initial_m2
232 0 : new_m2 = b% job% new_m2
233 0 : change_separation_eccentricity = b% job% change_separation_eccentricity
234 0 : change_initial_separation_eccentricity = b% job% change_initial_separation_eccentricity
235 0 : change_period_eccentricity = b% job% change_period_eccentricity
236 0 : change_initial_period_eccentricity = b% job% change_initial_period_eccentricity
237 0 : new_separation = b% job% new_separation
238 0 : new_period = b% job% new_period
239 0 : new_eccentricity = b% job% new_eccentricity
240 0 : pgbinary_flag = b% job% pgbinary_flag
241 :
242 0 : end subroutine set_binary_job_controls_for_writing
243 :
244 :
245 0 : subroutine do_write_binary_job(b, filename, ierr)
246 : type (binary_info), pointer :: b
247 : character(*), intent(in) :: filename
248 : integer, intent(out) :: ierr
249 : integer :: io
250 : ierr = 0
251 0 : call set_binary_job_controls_for_writing(b, ierr)
252 0 : if (ierr /= 0) return
253 0 : open(newunit=io, file=trim(filename), action='write', status='replace', iostat=ierr)
254 0 : if (ierr /= 0) then
255 0 : write(*,*) 'failed to open ' // trim(filename)
256 0 : return
257 : end if
258 0 : write(io, nml=binary_job, iostat=ierr)
259 0 : close(io)
260 : end subroutine do_write_binary_job
261 :
262 :
263 0 : subroutine get_binary_job(b, name, val, ierr)
264 : use utils_lib, only: StrUpCase
265 : type (binary_info), pointer :: b
266 : character(len=*),intent(in) :: name
267 : character(len=*), intent(out) :: val
268 : integer, intent(out) :: ierr
269 :
270 0 : character(len(name)) :: upper_name
271 : character(len=512) :: str
272 : integer :: iounit,iostat,ind,i
273 :
274 :
275 : ! First save current controls
276 0 : call set_binary_job_controls_for_writing(b, ierr)
277 0 : if(ierr/=0) return
278 :
279 : ! Write namelist to temporary file
280 0 : open(newunit=iounit,status='scratch')
281 0 : write(iounit,nml=binary_job)
282 0 : rewind(iounit)
283 :
284 : ! Namelists get written in capitals
285 0 : upper_name = StrUpCase(name)
286 0 : val = ''
287 : ! Search for name inside namelist
288 : do
289 0 : read(iounit,'(A)',iostat=iostat) str
290 0 : ind = index(str,trim(upper_name))
291 0 : if( ind /= 0 ) then
292 0 : val = str(ind+len_trim(upper_name)+1:len_trim(str)-1) ! Remove final comma and starting =
293 0 : do i=1,len(val)
294 0 : if(val(i:i)=='"') val(i:i) = ' '
295 : end do
296 : exit
297 : end if
298 0 : if(is_iostat_end(iostat)) exit
299 : end do
300 :
301 0 : if(len_trim(val) == 0 .and. ind==0 ) ierr = -1
302 :
303 0 : close(iounit)
304 :
305 0 : end subroutine get_binary_job
306 :
307 0 : subroutine set_binary_job(b, name, val, ierr)
308 : type (binary_info), pointer :: b
309 : character(len=*), intent(in) :: name, val
310 0 : character(len=len(name)+len(val)+14) :: tmp
311 : integer, intent(out) :: ierr
312 :
313 : ! First save current controls
314 0 : call set_binary_job_controls_for_writing(b, ierr)
315 0 : if(ierr/=0) return
316 :
317 0 : tmp=''
318 0 : tmp = '&binary_job '//trim(name)//'='//trim(val)//' /'
319 :
320 : ! Load into namelist
321 0 : read(tmp, nml=binary_job)
322 :
323 : ! Add to star
324 0 : call store_binary_job_controls(b, ierr)
325 0 : if(ierr/=0) return
326 :
327 : end subroutine set_binary_job
328 :
329 :
330 : end module binary_job_ctrls_io
331 :
|
