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 1 : end subroutine store_controls
164 :
165 0 : subroutine write_namelist(handle, filename, ierr)
166 : integer, intent(in) :: handle
167 : character(*), intent(in) :: filename
168 : integer, intent(out) :: ierr
169 : type(Colors_General_Info), pointer :: rq
170 : integer :: iounit
171 : open (newunit=iounit, file=trim(filename), &
172 0 : action='write', status='replace', iostat=ierr)
173 0 : if (ierr /= 0) then
174 0 : write (*, *) 'failed to open '//trim(filename)
175 0 : return
176 : end if
177 0 : call get_colors_ptr(handle, rq, ierr)
178 0 : if (ierr /= 0) then
179 0 : close (iounit)
180 0 : return
181 : end if
182 0 : call set_controls_for_writing(rq)
183 0 : write (iounit, nml=colors, iostat=ierr)
184 0 : close (iounit)
185 : end subroutine write_namelist
186 :
187 0 : subroutine set_controls_for_writing(rq)
188 : type(Colors_General_Info), pointer, intent(inout) :: rq
189 :
190 0 : instrument = rq%instrument
191 0 : vega_sed = rq%vega_sed
192 0 : stellar_atm = rq%stellar_atm
193 0 : distance = rq%distance
194 0 : make_csv = rq%make_csv
195 0 : colors_results_directory = rq%colors_results_directory
196 0 : use_colors = rq%use_colors
197 0 : mag_system = rq%mag_system
198 :
199 0 : end subroutine set_controls_for_writing
200 :
201 0 : subroutine get_colors_controls(rq, name, val, ierr)
202 : use utils_lib, only: StrUpCase
203 : type(Colors_General_Info), pointer, intent(inout) :: rq
204 : character(len=*), intent(in) :: name
205 : character(len=512), intent(out) :: val
206 : integer, intent(out) :: ierr
207 :
208 0 : character(len(name) + 1) :: upper_name
209 : character(len=512) :: str
210 : integer :: iounit, iostat, ind, i
211 :
212 0 : ierr = 0
213 :
214 : ! First save current controls
215 0 : call set_controls_for_writing(rq)
216 :
217 : ! Write namelist to temporary file
218 0 : open (newunit=iounit, status='scratch')
219 0 : write (iounit, nml=colors)
220 0 : rewind (iounit)
221 :
222 : ! Namelists get written in capitals
223 0 : upper_name = trim(StrUpCase(name))//'='
224 0 : val = ''
225 : ! Search for name inside namelist
226 : do
227 0 : read (iounit, '(A)', iostat=iostat) str
228 0 : ind = index(trim(str), trim(upper_name))
229 0 : if (ind /= 0) then
230 0 : val = str(ind + len_trim(upper_name):len_trim(str) - 1) ! Remove final comma and starting =
231 0 : do i = 1, len(val)
232 0 : if (val(i:i) == '"') val(i:i) = ' '
233 : end do
234 : exit
235 : end if
236 0 : if (is_iostat_end(iostat)) exit
237 : end do
238 :
239 0 : if (len_trim(val) == 0 .and. ind == 0) ierr = -1
240 :
241 0 : close (iounit)
242 :
243 0 : end subroutine get_colors_controls
244 :
245 0 : subroutine set_colors_controls(rq, name, val, ierr)
246 : type(Colors_General_Info), pointer, intent(inout) :: rq
247 : character(len=*), intent(in) :: name, val
248 0 : character(len=len(name) + len(val) + 8) :: tmp
249 : integer, intent(out) :: ierr
250 :
251 0 : ierr = 0
252 :
253 : ! First save current colors_controls
254 0 : call set_controls_for_writing(rq)
255 :
256 0 : tmp = ''
257 0 : tmp = '&colors '//trim(name)//'='//trim(val)//' /'
258 :
259 : ! Load into namelist
260 0 : read (tmp, nml=colors)
261 :
262 : ! Add to colors
263 0 : call store_controls(rq, ierr)
264 0 : if (ierr /= 0) return
265 :
266 : end subroutine set_colors_controls
267 :
268 : end module colors_ctrls_io
|
