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_lib
21 :
22 : use const_def, only: dp, strlen
23 : use bolometric, only: calculate_bolometric
24 : use synthetic, only: calculate_synthetic
25 : use colors_utils, only: read_strings_from_file
26 : use colors_history, only: how_many_colors_history_columns, data_for_colors_history_columns
27 :
28 : implicit none
29 :
30 : private
31 :
32 : public :: colors_init, colors_shutdown
33 : public :: alloc_colors_handle, alloc_colors_handle_using_inlist, free_colors_handle
34 : public :: colors_ptr
35 : public :: colors_setup_tables, colors_setup_hooks
36 : ! Main functions
37 : public :: calculate_bolometric, calculate_synthetic
38 : public :: how_many_colors_history_columns, data_for_colors_history_columns
39 : ! Old bolometric correction functions that MESA expects (stub implementations, remove later):
40 : public :: get_bc_id_by_name, get_lum_band_by_id, get_abs_mag_by_id
41 : public :: get_bc_by_id, get_bc_name_by_id, get_bc_by_name
42 : public :: get_abs_bolometric_mag, get_abs_mag_by_name, get_bcs_all
43 : public :: get_lum_band_by_name
44 : contains
45 :
46 : ! call this routine to initialize the colors module.
47 : ! only needs to be done once at start of run.
48 : ! Reads data from the 'colors' directory in the data_dir.
49 : ! If use_cache is true and there is a 'colors/cache' directory, it will try that first.
50 : ! If it doesn't find what it needs in the cache,
51 : ! it reads the data and writes the cache for next time.
52 1 : subroutine colors_init(use_cache, colors_cache_dir, ierr)
53 : use colors_def, only: colors_def_init, colors_use_cache, colors_is_initialized
54 : logical, intent(in) :: use_cache
55 : character(len=*), intent(in) :: colors_cache_dir ! blank means use default
56 : integer, intent(out) :: ierr ! 0 means AOK.
57 1 : ierr = 0
58 1 : if (colors_is_initialized) return
59 1 : call colors_def_init(colors_cache_dir)
60 1 : colors_use_cache = use_cache
61 1 : colors_is_initialized = .true.
62 : end subroutine colors_init
63 :
64 1 : subroutine colors_shutdown
65 : use colors_def, only: do_free_colors_tables, colors_is_initialized
66 1 : call do_free_colors_tables()
67 1 : colors_is_initialized = .false.
68 1 : end subroutine colors_shutdown
69 :
70 : ! after colors_init has finished, you can allocate a "handle".
71 0 : integer function alloc_colors_handle(ierr) result(handle)
72 : integer, intent(out) :: ierr ! 0 means AOK.
73 : character(len=0) :: inlist
74 0 : handle = alloc_colors_handle_using_inlist(inlist, ierr)
75 0 : end function alloc_colors_handle
76 :
77 4 : integer function alloc_colors_handle_using_inlist(inlist, ierr) result(handle)
78 : use colors_def, only: do_alloc_colors, colors_is_initialized
79 : use colors_ctrls_io, only: read_namelist
80 : character(len=*), intent(in) :: inlist ! empty means just use defaults.
81 : integer, intent(out) :: ierr ! 0 means AOK.
82 : ierr = 0
83 1 : if (.not. colors_is_initialized) then
84 0 : ierr = -1
85 0 : return
86 : end if
87 1 : handle = do_alloc_colors(ierr)
88 1 : if (ierr /= 0) return
89 1 : call read_namelist(handle, inlist, ierr)
90 1 : if (ierr /= 0) return
91 1 : call colors_setup_tables(handle, ierr)
92 1 : call colors_setup_hooks(handle, ierr)
93 1 : end function alloc_colors_handle_using_inlist
94 :
95 1 : subroutine free_colors_handle(handle)
96 : ! frees the handle and all associated data
97 : use colors_def, only: colors_General_Info, do_free_colors
98 : integer, intent(in) :: handle
99 1 : call do_free_colors(handle)
100 1 : end subroutine free_colors_handle
101 :
102 2 : subroutine colors_ptr(handle, rq, ierr)
103 :
104 : use colors_def, only: Colors_General_Info, get_colors_ptr, colors_is_initialized
105 :
106 : type(colors_General_Info), pointer, intent(out) :: rq
107 : integer, intent(in) :: handle
108 : integer, intent(out):: ierr
109 :
110 1 : if (.not. colors_is_initialized) then
111 0 : ierr = -1
112 0 : return
113 : end if
114 :
115 1 : call get_colors_ptr(handle, rq, ierr)
116 :
117 : end subroutine colors_ptr
118 :
119 2 : subroutine colors_setup_tables(handle, ierr)
120 : use colors_def, only: colors_General_Info, get_colors_ptr, color_filter_names, num_color_filters
121 : ! TODO: use load_colors, only: Setup_colors_Tables
122 : integer, intent(in) :: handle
123 : integer, intent(out):: ierr
124 :
125 : type(colors_General_Info), pointer :: rq
126 : logical, parameter :: use_cache = .true.
127 : logical, parameter :: load_on_demand = .true.
128 :
129 : ierr = 0
130 1 : call get_colors_ptr(handle, rq, ierr)
131 : ! TODO: call Setup_colors_Tables(rq, use_cache, load_on_demand, ierr)
132 :
133 : ! TODO: For now, don't use cache (future feature)
134 : ! but rely on user specifying a single filters directory, and read it here
135 1 : call read_strings_from_file(rq, color_filter_names, num_color_filters, ierr)
136 :
137 1 : end subroutine colors_setup_tables
138 :
139 1 : subroutine colors_setup_hooks(handle, ierr)
140 : use colors_def, only: colors_General_Info, get_colors_ptr
141 : integer, intent(in) :: handle
142 : integer, intent(out):: ierr
143 :
144 : type(colors_General_Info), pointer :: rq
145 :
146 : ierr = 0
147 1 : call get_colors_ptr(handle, rq, ierr)
148 :
149 : ! TODO: currently does nothing. See kap if this feature is needed
150 :
151 0 : end subroutine colors_setup_hooks
152 :
153 : !-----------------------------------------------------------------------
154 : ! Bolometric correction interface (stub implementations)
155 : !-----------------------------------------------------------------------
156 :
157 0 : real(dp) function get_bc_by_name(name, log_Teff, log_g, M_div_h, ierr)
158 : character(len=*), intent(in) :: name
159 : real(dp), intent(in) :: log_Teff ! log10 of surface temp
160 : real(dp), intent(in) :: log_g ! log_10 of surface gravity
161 : real(dp), intent(in) :: M_div_h ! [M/H]
162 : integer, intent(inout) :: ierr
163 :
164 0 : get_bc_by_name = -99.9d0
165 0 : ierr = 0
166 0 : end function get_bc_by_name
167 :
168 0 : real(dp) function get_bc_by_id(id, log_Teff, log_g, M_div_h, ierr)
169 : integer, intent(in) :: id
170 : real(dp), intent(in) :: log_Teff ! log10 of surface temp
171 : real(dp), intent(in) :: log_g ! log_10 of surface gravity
172 : real(dp), intent(in) :: M_div_h ! [M/H]
173 : integer, intent(inout) :: ierr
174 :
175 0 : get_bc_by_id = -99.9d0
176 0 : ierr = 0
177 0 : end function get_bc_by_id
178 :
179 0 : integer function get_bc_id_by_name(name, ierr)
180 : character(len=*), intent(in) :: name
181 : integer, intent(inout) :: ierr
182 :
183 0 : get_bc_id_by_name = -1
184 0 : ierr = 0
185 0 : end function get_bc_id_by_name
186 :
187 0 : character(len=strlen) function get_bc_name_by_id(id, ierr)
188 : integer, intent(in) :: id
189 : integer, intent(inout) :: ierr
190 :
191 0 : get_bc_name_by_id = ''
192 0 : ierr = 0
193 0 : end function get_bc_name_by_id
194 :
195 0 : real(dp) function get_abs_bolometric_mag(lum)
196 : use const_def, only: dp
197 : real(dp), intent(in) :: lum ! Luminosity in lsun units
198 :
199 0 : get_abs_bolometric_mag = -99.9d0
200 0 : end function get_abs_bolometric_mag
201 :
202 0 : real(dp) function get_abs_mag_by_name(name, log_Teff, log_g, M_div_h, lum, ierr)
203 : character(len=*), intent(in) :: name
204 : real(dp), intent(in) :: log_Teff ! log10 of surface temp
205 : real(dp), intent(in) :: M_div_h ! [M/H]
206 : real(dp), intent(in) :: log_g ! log_10 of surface gravity
207 : real(dp), intent(in) :: lum ! Luminosity in lsun units
208 : integer, intent(inout) :: ierr
209 :
210 0 : ierr = 0
211 0 : get_abs_mag_by_name = -99.9d0
212 0 : end function get_abs_mag_by_name
213 :
214 0 : real(dp) function get_abs_mag_by_id(id, log_Teff, log_g, M_div_h, lum, ierr)
215 : integer, intent(in) :: id
216 : real(dp), intent(in) :: log_Teff ! log10 of surface temp
217 : real(dp), intent(in) :: log_g ! log_10 of surface gravity
218 : real(dp), intent(in) :: M_div_h ! [M/H]
219 : real(dp), intent(in) :: lum ! Luminosity in lsun units
220 : integer, intent(inout) :: ierr
221 :
222 0 : ierr = 0
223 0 : get_abs_mag_by_id = -99.9d0
224 0 : end function get_abs_mag_by_id
225 :
226 0 : subroutine get_bcs_all(log_Teff, log_g, M_div_h, results, ierr)
227 : real(dp), intent(in) :: log_Teff ! log10 of surface temp
228 : real(dp), intent(in) :: M_div_h ! [M/H]
229 : real(dp), dimension(:), intent(out) :: results
230 : real(dp), intent(in) :: log_g
231 : integer, intent(inout) :: ierr
232 :
233 0 : ierr = 0
234 0 : results(:) = -99.d0
235 0 : end subroutine get_bcs_all
236 :
237 0 : real(dp) function get_lum_band_by_name(name, log_Teff, log_g, M_div_h, lum, ierr)
238 : character(len=*), intent(in) :: name
239 : real(dp), intent(in) :: log_Teff ! log10 of surface temp
240 : real(dp), intent(in) :: M_div_h ! [M/H]
241 : real(dp), intent(in) :: log_g ! log_10 of surface gravity
242 : real(dp), intent(in) :: lum ! Total luminosity in lsun units
243 : integer, intent(inout) :: ierr
244 :
245 0 : ierr = 0
246 0 : get_lum_band_by_name = -99.d0
247 0 : end function get_lum_band_by_name
248 :
249 0 : real(dp) function get_lum_band_by_id(id, log_Teff, log_g, M_div_h, lum, ierr)
250 : integer, intent(in) :: id
251 : real(dp), intent(in) :: log_Teff ! log10 of surface temp
252 : real(dp), intent(in) :: log_g ! log_10 of surface gravity
253 : real(dp), intent(in) :: M_div_h ! [M/H]
254 : real(dp), intent(in) :: lum ! Total luminosity in lsun units
255 : integer, intent(inout) :: ierr
256 :
257 0 : ierr = 0
258 0 : get_lum_band_by_id = -99.d0
259 0 : end function get_lum_band_by_id
260 :
261 : end module colors_lib
|
