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