Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2025 Niall Miller & 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 colors_ctrls_io
21 :
22 : use const_def, only: dp, strlen, max_extra_inlists
23 : use colors_def, only: Colors_General_Info, get_colors_ptr
24 :
25 : implicit none
26 :
27 : public :: read_namelist, write_namelist, get_colors_controls, set_colors_controls
28 :
29 : private
30 :
31 : logical, dimension(max_extra_inlists) :: read_extra_colors_inlist
32 : character(len=strlen), dimension(max_extra_inlists) :: extra_colors_inlist_name
33 :
34 : character(len=256) :: instrument
35 : character(len=256) :: vega_sed
36 : character(len=256) :: stellar_atm
37 : character(len=256) :: colors_results_directory
38 : character(len=256) :: mag_system
39 :
40 : real(dp) :: distance
41 : real(dp) :: z_over_x_ref
42 : logical :: make_csv
43 : logical :: sed_per_model
44 : logical :: use_colors
45 :
46 : namelist /colors/ &
47 : instrument, &
48 : vega_sed, &
49 : stellar_atm, &
50 : distance, &
51 : z_over_x_ref, &
52 : make_csv, &
53 : sed_per_model, &
54 : mag_system, &
55 : colors_results_directory, &
56 : use_colors, &
57 : read_extra_colors_inlist, &
58 : extra_colors_inlist_name
59 :
60 : contains
61 :
62 2 : subroutine read_namelist(handle, inlist, ierr)
63 : integer, intent(in) :: handle
64 : character(len=*), intent(in) :: inlist
65 : integer, intent(out) :: ierr ! 0 means AOK.
66 : type(Colors_General_Info), pointer :: rq
67 : include 'formats'
68 2 : call get_colors_ptr(handle, rq, ierr)
69 2 : if (ierr /= 0) return
70 2 : call set_default_controls
71 2 : call read_controls_file(rq, inlist, 1, ierr)
72 2 : if (ierr /= 0) return
73 : end subroutine read_namelist
74 :
75 3 : recursive subroutine read_controls_file(rq, filename, level, ierr)
76 : use iso_fortran_env, only: iostat_end
77 : character(*), intent(in) :: filename
78 : integer, intent(in) :: level
79 : type(Colors_General_Info), pointer, intent(inout) :: rq
80 : integer, intent(out) :: ierr
81 : logical, dimension(max_extra_inlists) :: read_extra
82 : character(len=strlen), dimension(max_extra_inlists) :: extra
83 : integer :: unit, i
84 :
85 2 : ierr = 0
86 2 : if (level >= 10) then
87 0 : write (*, *) 'ERROR: too many levels of nested extra controls inlist files'
88 0 : ierr = -1
89 2 : return
90 : end if
91 :
92 2 : if (len_trim(filename) > 0) then
93 : open (newunit=unit, file=trim(filename), &
94 1 : action='read', delim='quote', status='old', iostat=ierr)
95 1 : if (ierr /= 0) then
96 0 : if (level == 1) then
97 : ierr = 0 ! no inlist file so just use defaults
98 0 : call store_controls(rq, ierr)
99 : else
100 0 : write (*, *) 'Failed to open colors namelist file ', trim(filename)
101 : end if
102 0 : return
103 : end if
104 1 : read (unit, nml=colors, iostat=ierr)
105 1 : close (unit)
106 1 : if (ierr == IOSTAT_END) then ! end-of-file means didn't find an &colors namelist
107 1 : ierr = 0
108 1 : write (*, *) 'WARNING: Failed to find colors namelist in file: ', trim(filename)
109 1 : call store_controls(rq, ierr)
110 1 : close (unit)
111 1 : return
112 0 : else if (ierr /= 0) then
113 0 : write (*, *)
114 0 : write (*, *)
115 0 : write (*, *)
116 0 : write (*, *)
117 0 : write (*, '(a)') 'Failed while trying to read colors namelist file: '//trim(filename)
118 0 : write (*, '(a)') 'Perhaps the following runtime error message will help you find the problem.'
119 0 : write (*, *)
120 : open (newunit=unit, file=trim(filename), action='read', &
121 0 : delim='quote', status='old', iostat=ierr)
122 0 : read (unit, nml=colors)
123 0 : close (unit)
124 0 : return
125 : end if
126 : end if
127 :
128 1 : call store_controls(rq, ierr)
129 :
130 1 : if (len_trim(filename) == 0) return
131 :
132 : ! recursive calls to read other inlists
133 0 : do i = 1, max_extra_inlists
134 0 : read_extra(i) = read_extra_colors_inlist(i)
135 0 : read_extra_colors_inlist(i) = .false.
136 0 : extra(i) = extra_colors_inlist_name(i)
137 0 : extra_colors_inlist_name(i) = 'undefined'
138 :
139 0 : if (read_extra(i)) then
140 0 : call read_controls_file(rq, extra(i), level + 1, ierr)
141 0 : if (ierr /= 0) return
142 : end if
143 : end do
144 :
145 : end subroutine read_controls_file
146 :
147 2 : subroutine set_default_controls
148 : include 'colors.defaults'
149 2 : end subroutine set_default_controls
150 :
151 2 : subroutine store_controls(rq, ierr)
152 : type(Colors_General_Info), pointer, intent(inout) :: rq
153 :
154 : integer, intent(out) :: ierr
155 :
156 2 : rq%instrument = instrument
157 2 : rq%vega_sed = vega_sed
158 2 : rq%stellar_atm = stellar_atm
159 2 : rq%distance = distance
160 2 : rq%z_over_x_ref = z_over_x_ref
161 2 : rq%make_csv = make_csv
162 2 : rq%sed_per_model = sed_per_model
163 2 : rq%colors_results_directory = colors_results_directory
164 2 : rq%use_colors = use_colors
165 2 : rq%mag_system = mag_system
166 :
167 2 : end subroutine store_controls
168 :
169 0 : subroutine write_namelist(handle, filename, ierr)
170 : integer, intent(in) :: handle
171 : character(*), intent(in) :: filename
172 : integer, intent(out) :: ierr
173 : type(Colors_General_Info), pointer :: rq
174 : integer :: iounit
175 : open (newunit=iounit, file=trim(filename), &
176 0 : action='write', status='replace', iostat=ierr)
177 0 : if (ierr /= 0) then
178 0 : write (*, *) 'failed to open '//trim(filename)
179 0 : return
180 : end if
181 0 : call get_colors_ptr(handle, rq, ierr)
182 0 : if (ierr /= 0) then
183 0 : close (iounit)
184 0 : return
185 : end if
186 0 : call set_controls_for_writing(rq)
187 0 : write (iounit, nml=colors, iostat=ierr)
188 0 : close (iounit)
189 : end subroutine write_namelist
190 :
191 0 : subroutine set_controls_for_writing(rq)
192 : type(Colors_General_Info), pointer, intent(inout) :: rq
193 :
194 0 : instrument = rq%instrument
195 0 : vega_sed = rq%vega_sed
196 0 : stellar_atm = rq%stellar_atm
197 0 : distance = rq%distance
198 0 : z_over_x_ref = rq%z_over_x_ref
199 0 : make_csv = rq%make_csv
200 0 : sed_per_model = rq%sed_per_model
201 0 : colors_results_directory = rq%colors_results_directory
202 0 : use_colors = rq%use_colors
203 0 : mag_system = rq%mag_system
204 :
205 0 : end subroutine set_controls_for_writing
206 :
207 0 : subroutine get_colors_controls(rq, name, val, ierr)
208 : use utils_lib, only: StrUpCase
209 : type(Colors_General_Info), pointer, intent(inout) :: rq
210 : character(len=*), intent(in) :: name
211 : character(len=512), intent(out) :: val
212 : integer, intent(out) :: ierr
213 :
214 0 : character(len(name) + 1) :: upper_name
215 : character(len=512) :: str
216 : integer :: iounit, iostat, ind, i
217 :
218 0 : ierr = 0
219 :
220 : ! save current controls
221 0 : call set_controls_for_writing(rq)
222 :
223 : ! write namelist to temporary file
224 0 : open (newunit=iounit, status='scratch')
225 0 : write (iounit, nml=colors)
226 0 : rewind (iounit)
227 :
228 : ! namelists get written in capitals
229 0 : upper_name = trim(StrUpCase(name))//'='
230 0 : val = ''
231 : do
232 0 : read (iounit, '(A)', iostat=iostat) str
233 0 : ind = index(trim(str), trim(upper_name))
234 0 : if (ind /= 0) then
235 0 : val = str(ind + len_trim(upper_name):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_colors_controls
249 :
250 0 : subroutine set_colors_controls(rq, name, val, ierr)
251 : type(Colors_General_Info), pointer, intent(inout) :: rq
252 : character(len=*), intent(in) :: name, val
253 0 : character(len=len(name) + len(val) + 8) :: tmp
254 : integer, intent(out) :: ierr
255 :
256 0 : ierr = 0
257 :
258 : ! save current controls
259 0 : call set_controls_for_writing(rq)
260 :
261 0 : tmp = ''
262 0 : tmp = '&colors '//trim(name)//'='//trim(val)//' /'
263 :
264 0 : read (tmp, nml=colors)
265 :
266 0 : call store_controls(rq, ierr)
267 0 : if (ierr /= 0) return
268 :
269 : end subroutine set_colors_controls
270 :
271 : end module colors_ctrls_io
|
