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
23 : use utils_namelist, only: max_extra_inlists
24 : use colors_def, only: Colors_General_Info, get_colors_ptr
25 :
26 : implicit none
27 :
28 : public :: read_colors_namelist, write_namelist, get_colors_controls, set_colors_controls
29 :
30 : private
31 :
32 : logical, dimension(max_extra_inlists) :: read_extra_colors_inlist
33 : character(len=strlen), dimension(max_extra_inlists) :: extra_colors_inlist_name
34 :
35 : character(len=256) :: instrument
36 : character(len=256) :: vega_sed
37 : character(len=256) :: stellar_atm
38 : character(len=256) :: colors_results_directory
39 : character(len=256) :: mag_system
40 :
41 : real(dp) :: distance
42 : real(dp) :: z_over_x_ref
43 : logical :: make_csv
44 : logical :: sed_per_model
45 : logical :: use_colors
46 :
47 : namelist /colors/ &
48 : instrument, &
49 : vega_sed, &
50 : stellar_atm, &
51 : distance, &
52 : z_over_x_ref, &
53 : make_csv, &
54 : sed_per_model, &
55 : mag_system, &
56 : colors_results_directory, &
57 : use_colors, &
58 : read_extra_colors_inlist, &
59 : extra_colors_inlist_name
60 :
61 : contains
62 :
63 2 : subroutine read_colors_namelist(handle, inlist, ierr)
64 : use utils_namelist, only: read_namelist, missing_namelist_warning
65 : integer, intent(in) :: handle
66 : character(len=*), intent(in) :: inlist
67 : integer, intent(out) :: ierr ! 0 means AOK.
68 : type(Colors_General_Info), pointer :: rq
69 :
70 2 : call get_colors_ptr(handle, rq, ierr)
71 :
72 2 : if (ierr /= 0) return
73 :
74 2 : call set_default_controls
75 2 : call read_namelist(inlist, read_colors_file, "colors", ierr, missing_namelist_warning)
76 :
77 2 : if (ierr /= 0) return
78 :
79 2 : call store_controls(rq)
80 : end subroutine read_colors_namelist
81 :
82 1 : subroutine read_colors_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask)
83 : use const_def, only: strlen
84 : use utils_namelist, only: max_extra_inlists
85 :
86 : integer, intent(in) :: unit
87 : integer, intent(out) :: iostat
88 : character(len=strlen), intent(out) :: iomsg
89 : character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists
90 : logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask
91 :
92 : integer :: i
93 :
94 1 : read_extra_colors_inlist(:) = .false.
95 :
96 1 : read(unit, nml=colors, iostat=iostat, iomsg=iomsg)
97 :
98 1 : if (iostat /= 0) then
99 : return
100 : end if
101 :
102 0 : do i=1, max_extra_inlists
103 0 : extra_inlists(i) = extra_colors_inlist_name(i)
104 0 : extra_inlists_mask(i) = read_extra_colors_inlist(i)
105 : end do
106 :
107 : end subroutine read_colors_file
108 :
109 2 : subroutine set_default_controls
110 : include 'colors.defaults'
111 2 : end subroutine set_default_controls
112 :
113 2 : subroutine store_controls(rq)
114 : type(Colors_General_Info), pointer, intent(inout) :: rq
115 :
116 2 : rq%instrument = instrument
117 2 : rq%vega_sed = vega_sed
118 2 : rq%stellar_atm = stellar_atm
119 2 : rq%distance = distance
120 2 : rq%z_over_x_ref = z_over_x_ref
121 2 : rq%make_csv = make_csv
122 2 : rq%sed_per_model = sed_per_model
123 2 : rq%colors_results_directory = colors_results_directory
124 2 : rq%use_colors = use_colors
125 2 : rq%mag_system = mag_system
126 :
127 2 : end subroutine store_controls
128 :
129 0 : subroutine write_namelist(handle, filename, ierr)
130 : integer, intent(in) :: handle
131 : character(*), intent(in) :: filename
132 : integer, intent(out) :: ierr
133 : type(Colors_General_Info), pointer :: rq
134 : integer :: iounit
135 : open (newunit=iounit, file=trim(filename), &
136 0 : action='write', status='replace', iostat=ierr)
137 0 : if (ierr /= 0) then
138 0 : write (*, *) 'failed to open '//trim(filename)
139 0 : return
140 : end if
141 0 : call get_colors_ptr(handle, rq, ierr)
142 0 : if (ierr /= 0) then
143 0 : close (iounit)
144 0 : return
145 : end if
146 0 : call set_controls_for_writing(rq)
147 0 : write (iounit, nml=colors, iostat=ierr)
148 0 : close (iounit)
149 : end subroutine write_namelist
150 :
151 0 : subroutine set_controls_for_writing(rq)
152 : type(Colors_General_Info), pointer, intent(inout) :: rq
153 :
154 0 : instrument = rq%instrument
155 0 : vega_sed = rq%vega_sed
156 0 : stellar_atm = rq%stellar_atm
157 0 : distance = rq%distance
158 0 : z_over_x_ref = rq%z_over_x_ref
159 0 : make_csv = rq%make_csv
160 0 : sed_per_model = rq%sed_per_model
161 0 : colors_results_directory = rq%colors_results_directory
162 0 : use_colors = rq%use_colors
163 0 : mag_system = rq%mag_system
164 :
165 0 : end subroutine set_controls_for_writing
166 :
167 0 : subroutine get_colors_controls(rq, name, val, ierr)
168 : use utils_lib, only: StrUpCase
169 : type(Colors_General_Info), pointer, intent(inout) :: rq
170 : character(len=*), intent(in) :: name
171 : character(len=512), intent(out) :: val
172 : integer, intent(out) :: ierr
173 :
174 0 : character(len(name) + 1) :: upper_name
175 : character(len=512) :: str
176 : integer :: iounit, iostat, ind, i
177 :
178 0 : ierr = 0
179 :
180 : ! save current controls
181 0 : call set_controls_for_writing(rq)
182 :
183 : ! write namelist to temporary file
184 0 : open (newunit=iounit, status='scratch')
185 0 : write (iounit, nml=colors)
186 0 : rewind (iounit)
187 :
188 : ! namelists get written in capitals
189 0 : upper_name = trim(StrUpCase(name))//'='
190 0 : val = ''
191 : do
192 0 : read (iounit, '(A)', iostat=iostat) str
193 0 : ind = index(trim(str), trim(upper_name))
194 0 : if (ind /= 0) then
195 0 : val = str(ind + len_trim(upper_name):len_trim(str) - 1) ! Remove final comma and starting =
196 0 : do i = 1, len(val)
197 0 : if (val(i:i) == '"') val(i:i) = ' '
198 : end do
199 : exit
200 : end if
201 0 : if (is_iostat_end(iostat)) exit
202 : end do
203 :
204 0 : if (len_trim(val) == 0 .and. ind == 0) ierr = -1
205 :
206 0 : close (iounit)
207 :
208 0 : end subroutine get_colors_controls
209 :
210 0 : subroutine set_colors_controls(rq, name, val, ierr)
211 : type(Colors_General_Info), pointer, intent(inout) :: rq
212 : character(len=*), intent(in) :: name, val
213 0 : character(len=len(name) + len(val) + 8) :: tmp
214 : integer, intent(out) :: ierr
215 :
216 0 : ierr = 0
217 :
218 : ! save current controls
219 0 : call set_controls_for_writing(rq)
220 :
221 0 : tmp = ''
222 0 : tmp = '&colors '//trim(name)//'='//trim(val)//' /'
223 :
224 0 : read (tmp, nml=colors)
225 :
226 0 : call store_controls(rq)
227 0 : end subroutine set_colors_controls
228 :
229 : end module colors_ctrls_io
|
