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