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 : change_ignore_rlof_flag, &
38 : change_initial_ignore_rlof_flag, &
39 : new_ignore_rlof_flag, &
40 : change_model_twins_flag, &
41 : change_initial_model_twins_flag, &
42 : new_model_twins_flag, &
43 : change_point_mass_i, &
44 : change_initial_point_mass_i, &
45 : new_point_mass_i, &
46 : change_m1, &
47 : change_initial_m1, &
48 : new_m1, &
49 : change_m2, &
50 : change_initial_m2, &
51 : new_m2, &
52 : change_separation_eccentricity, &
53 : change_initial_separation_eccentricity, &
54 : change_period_eccentricity, &
55 : change_initial_period_eccentricity, &
56 : new_separation, &
57 : new_period, &
58 : new_eccentricity, &
59 : pgbinary_flag
60 :
61 : contains
62 :
63 :
64 0 : subroutine do_read_binary_job(b, filename, ierr)
65 : use utils_namelist, only: read_namelist, missing_namelist_error
66 : type (binary_info), pointer :: b
67 : character(*), intent(in) :: filename
68 : integer, intent(out) :: ierr
69 :
70 0 : call set_default_binary_job_controls
71 0 : call read_namelist(filename, read_binary_job_file, "binary_job", ierr, missing_namelist_error)
72 :
73 0 : if (ierr /= 0) return
74 :
75 0 : call store_binary_job_controls(b)
76 : end subroutine do_read_binary_job
77 :
78 0 : subroutine read_binary_job_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask)
79 : use const_def, only: strlen
80 : use utils_namelist, only: max_extra_inlists
81 :
82 : integer, intent(in) :: unit
83 : integer, intent(out) :: iostat
84 : character(len=strlen), intent(out) :: iomsg
85 : character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists
86 : logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask
87 :
88 : integer :: i
89 :
90 0 : read_extra_binary_job_inlist(:) = .false.
91 :
92 0 : read(unit, nml=binary_job, iostat=iostat, iomsg=iomsg)
93 :
94 0 : if (iostat /= 0) then
95 : return
96 : end if
97 :
98 0 : do i=1, max_extra_inlists
99 0 : extra_inlists(i) = extra_binary_job_inlist_name(i)
100 0 : extra_inlists_mask(i) = read_extra_binary_job_inlist(i)
101 : end do
102 :
103 : end subroutine read_binary_job_file
104 :
105 0 : subroutine store_binary_job_controls(b)
106 : type (binary_info), pointer :: b
107 :
108 0 : b% job% show_binary_log_description_at_start = show_binary_log_description_at_start
109 0 : b% job% binary_history_columns_file = binary_history_columns_file
110 0 : b% job% warn_binary_extra = warn_binary_extra
111 0 : b% job% inlist_names(:) = inlist_names(:)
112 :
113 0 : b% job% evolve_both_stars = evolve_both_stars
114 :
115 0 : b% job% change_ignore_rlof_flag = change_ignore_rlof_flag
116 0 : b% job% change_initial_ignore_rlof_flag = change_initial_ignore_rlof_flag
117 0 : b% job% new_ignore_rlof_flag = new_ignore_rlof_flag
118 0 : b% job% change_model_twins_flag = change_model_twins_flag
119 0 : b% job% change_initial_model_twins_flag = change_initial_model_twins_flag
120 0 : b% job% new_model_twins_flag = new_model_twins_flag
121 0 : b% job% change_point_mass_i = change_point_mass_i
122 0 : b% job% change_initial_point_mass_i = change_initial_point_mass_i
123 0 : b% job% new_point_mass_i = new_point_mass_i
124 0 : b% job% change_m1 = change_m1
125 0 : b% job% change_initial_m1 = change_initial_m1
126 0 : b% job% new_m1 = new_m1
127 0 : b% job% change_m2 = change_m2
128 0 : b% job% change_initial_m2 = change_initial_m2
129 0 : b% job% new_m2 = new_m2
130 0 : b% job% change_separation_eccentricity = change_separation_eccentricity
131 0 : b% job% change_initial_separation_eccentricity = change_initial_separation_eccentricity
132 0 : b% job% change_period_eccentricity = change_period_eccentricity
133 0 : b% job% change_initial_period_eccentricity = change_initial_period_eccentricity
134 0 : b% job% new_separation = new_separation
135 0 : b% job% new_period = new_period
136 0 : b% job% new_eccentricity = new_eccentricity
137 0 : b% job% pgbinary_flag = pgbinary_flag
138 :
139 0 : end subroutine store_binary_job_controls
140 :
141 :
142 0 : subroutine set_default_binary_job_controls
143 : include 'binary_job.defaults'
144 0 : end subroutine set_default_binary_job_controls
145 :
146 :
147 0 : subroutine set_binary_job_controls_for_writing(b, ierr)
148 : type (binary_info), pointer :: b
149 : integer, intent(out) :: ierr
150 :
151 0 : ierr = 0
152 :
153 0 : show_binary_log_description_at_start = b% job% show_binary_log_description_at_start
154 0 : binary_history_columns_file = b% job% binary_history_columns_file
155 0 : warn_binary_extra = b% job% warn_binary_extra
156 0 : inlist_names(:) = b% job% inlist_names(:)
157 :
158 0 : evolve_both_stars = b% job% evolve_both_stars
159 0 : evolve_both_stars = b% job% evolve_both_stars
160 :
161 0 : change_ignore_rlof_flag = b% job% change_ignore_rlof_flag
162 0 : change_initial_ignore_rlof_flag = b% job% change_initial_ignore_rlof_flag
163 0 : new_ignore_rlof_flag = b% job% new_ignore_rlof_flag
164 0 : change_model_twins_flag = b% job% change_model_twins_flag
165 0 : change_initial_model_twins_flag = b% job% change_initial_model_twins_flag
166 0 : new_model_twins_flag = b% job% new_model_twins_flag
167 0 : change_point_mass_i = b% job% change_point_mass_i
168 0 : change_initial_point_mass_i = b% job% change_initial_point_mass_i
169 0 : new_point_mass_i = b% job% new_point_mass_i
170 0 : change_m1 = b% job% change_m1
171 0 : change_initial_m1 = b% job% change_initial_m1
172 0 : new_m1 = b% job% new_m1
173 0 : change_m2 = b% job% change_m2
174 0 : change_initial_m2 = b% job% change_initial_m2
175 0 : new_m2 = b% job% new_m2
176 0 : change_separation_eccentricity = b% job% change_separation_eccentricity
177 0 : change_initial_separation_eccentricity = b% job% change_initial_separation_eccentricity
178 0 : change_period_eccentricity = b% job% change_period_eccentricity
179 0 : change_initial_period_eccentricity = b% job% change_initial_period_eccentricity
180 0 : new_separation = b% job% new_separation
181 0 : new_period = b% job% new_period
182 0 : new_eccentricity = b% job% new_eccentricity
183 0 : pgbinary_flag = b% job% pgbinary_flag
184 :
185 0 : end subroutine set_binary_job_controls_for_writing
186 :
187 :
188 0 : subroutine do_write_binary_job(b, filename, ierr)
189 : type (binary_info), pointer :: b
190 : character(*), intent(in) :: filename
191 : integer, intent(out) :: ierr
192 : integer :: io
193 : ierr = 0
194 0 : call set_binary_job_controls_for_writing(b, ierr)
195 0 : if (ierr /= 0) return
196 0 : open(newunit=io, file=trim(filename), action='write', status='replace', iostat=ierr)
197 0 : if (ierr /= 0) then
198 0 : write(*,*) 'failed to open ' // trim(filename)
199 0 : return
200 : end if
201 0 : write(io, nml=binary_job, iostat=ierr)
202 0 : close(io)
203 : end subroutine do_write_binary_job
204 :
205 :
206 0 : subroutine get_binary_job(b, name, val, ierr)
207 : use utils_lib, only: StrUpCase
208 : type (binary_info), pointer :: b
209 : character(len=*),intent(in) :: name
210 : character(len=*), intent(out) :: val
211 : integer, intent(out) :: ierr
212 :
213 0 : character(len(name)) :: upper_name
214 : character(len=512) :: str
215 : integer :: iounit,iostat,ind,i
216 :
217 :
218 : ! First save current controls
219 0 : call set_binary_job_controls_for_writing(b, ierr)
220 0 : if(ierr/=0) return
221 :
222 : ! Write namelist to temporary file
223 0 : open(newunit=iounit,status='scratch')
224 0 : write(iounit,nml=binary_job)
225 0 : rewind(iounit)
226 :
227 : ! Namelists get written in capitals
228 0 : upper_name = StrUpCase(name)
229 0 : val = ''
230 : ! Search for name inside namelist
231 : do
232 0 : read(iounit,'(A)',iostat=iostat) str
233 0 : ind = index(str,trim(upper_name))
234 0 : if( ind /= 0 ) then
235 0 : val = str(ind+len_trim(upper_name)+1:len_trim(str)-1) ! Remove final comma and starting =
236 0 : do i=1,len(val)
237 0 : if(val(i:i)=='"') val(i:i) = ' '
238 : end do
239 : exit
240 : end if
241 0 : if(is_iostat_end(iostat)) exit
242 : end do
243 :
244 0 : if(len_trim(val) == 0 .and. ind==0 ) ierr = -1
245 :
246 0 : close(iounit)
247 :
248 0 : end subroutine get_binary_job
249 :
250 0 : subroutine set_binary_job(b, name, val, ierr)
251 : type (binary_info), pointer :: b
252 : character(len=*), intent(in) :: name, val
253 0 : character(len=len(name)+len(val)+14) :: tmp
254 : integer, intent(out) :: ierr
255 :
256 : ! First save current controls
257 0 : call set_binary_job_controls_for_writing(b, ierr)
258 0 : if(ierr/=0) return
259 :
260 0 : tmp=''
261 0 : tmp = '&binary_job '//trim(name)//'='//trim(val)//' /'
262 :
263 : ! Load into namelist
264 0 : read(tmp, nml=binary_job)
265 :
266 : ! Add to star
267 0 : call store_binary_job_controls(b)
268 0 : if(ierr/=0) return
269 :
270 : end subroutine set_binary_job
271 :
272 :
273 : end module binary_job_ctrls_io
274 :
|
