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_def
21 :
22 : use const_def, only: dp
23 :
24 : implicit none
25 :
26 : ! Make everything in this module public by default
27 : public
28 :
29 : ! Type to hold individual filter data
30 : type :: filter_data
31 : character(len=100) :: name
32 : real(dp), allocatable :: wavelengths(:)
33 : real(dp), allocatable :: transmission(:)
34 : ! Precomputed zero-point fluxes (computed once at initialization)
35 : real(dp) :: vega_zero_point = -1.0_dp
36 : real(dp) :: ab_zero_point = -1.0_dp
37 : real(dp) :: st_zero_point = -1.0_dp
38 : end type filter_data
39 :
40 : ! Colors Module control parameters
41 : type :: Colors_General_Info
42 : character(len=256) :: instrument
43 : character(len=256) :: vega_sed
44 : character(len=256) :: stellar_atm
45 : character(len=256) :: colors_results_directory
46 : character(len=256) :: mag_system
47 : real(dp) :: metallicity
48 : real(dp) :: distance
49 : logical :: make_csv
50 : logical :: use_colors
51 : integer :: handle
52 : logical :: in_use
53 :
54 : ! Cached lookup table data
55 : logical :: lookup_loaded = .false.
56 : character(len=100), allocatable :: lu_file_names(:)
57 : real(dp), allocatable :: lu_logg(:)
58 : real(dp), allocatable :: lu_meta(:)
59 : real(dp), allocatable :: lu_teff(:)
60 :
61 : ! Cached Vega SED
62 : logical :: vega_loaded = .false.
63 : real(dp), allocatable :: vega_wavelengths(:)
64 : real(dp), allocatable :: vega_fluxes(:)
65 :
66 : ! Cached filter data (includes precomputed zero-points)
67 : logical :: filters_loaded = .false.
68 : type(filter_data), allocatable :: filters(:)
69 :
70 : end type Colors_General_Info
71 :
72 : ! Global filter name list (shared across handles)
73 : integer :: num_color_filters
74 : character(len=100), allocatable :: color_filter_names(:)
75 :
76 : integer, parameter :: max_colors_handles = 10
77 : type(Colors_General_Info), target :: colors_handles(max_colors_handles)
78 :
79 : logical :: colors_is_initialized = .false.
80 :
81 : character(len=1000) :: colors_dir, colors_cache_dir, colors_temp_cache_dir
82 : logical :: colors_use_cache = .true.
83 :
84 : contains
85 :
86 1 : subroutine colors_def_init(colors_cache_dir_in)
87 : use utils_lib, only: mkdir
88 : use const_def, only: mesa_data_dir, mesa_caches_dir, mesa_temp_caches_dir, use_mesa_temp_cache
89 : character(*), intent(in) :: colors_cache_dir_in
90 : integer :: i
91 :
92 1 : if (len_trim(colors_cache_dir_in) > 0) then
93 0 : colors_cache_dir = colors_cache_dir_in
94 1 : else if (len_trim(mesa_caches_dir) > 0) then
95 0 : colors_cache_dir = trim(mesa_caches_dir)//'/colors_cache'
96 : else
97 1 : colors_cache_dir = trim(mesa_data_dir)//'/colors_data/cache'
98 : end if
99 1 : call mkdir(colors_cache_dir)
100 :
101 11 : do i = 1, max_colors_handles
102 10 : colors_handles(i)%handle = i
103 10 : colors_handles(i)%in_use = .false.
104 10 : colors_handles(i)%lookup_loaded = .false.
105 10 : colors_handles(i)%vega_loaded = .false.
106 11 : colors_handles(i)%filters_loaded = .false.
107 : end do
108 :
109 1 : colors_temp_cache_dir = trim(mesa_temp_caches_dir)//'/colors_cache'
110 1 : if (use_mesa_temp_cache) call mkdir(colors_temp_cache_dir)
111 :
112 1 : end subroutine colors_def_init
113 :
114 1 : integer function do_alloc_colors(ierr)
115 : integer, intent(out) :: ierr
116 : integer :: i
117 1 : ierr = 0
118 1 : do_alloc_colors = -1
119 2 : !$omp critical (colors_handle)
120 1 : do i = 1, max_colors_handles
121 1 : if (.not. colors_handles(i)%in_use) then
122 1 : colors_handles(i)%in_use = .true.
123 1 : do_alloc_colors = i
124 1 : exit
125 : end if
126 : end do
127 : !$omp end critical (colors_handle)
128 1 : if (do_alloc_colors == -1) then
129 0 : ierr = -1
130 0 : return
131 : end if
132 1 : if (colors_handles(do_alloc_colors)%handle /= do_alloc_colors) then
133 0 : ierr = -1
134 0 : return
135 : end if
136 : end function do_alloc_colors
137 :
138 1 : subroutine do_free_colors(handle)
139 : integer, intent(in) :: handle
140 1 : if (handle >= 1 .and. handle <= max_colors_handles) then
141 1 : colors_handles(handle)%in_use = .false.
142 1 : call free_colors_cache(handle)
143 : end if
144 1 : end subroutine do_free_colors
145 :
146 11 : subroutine free_colors_cache(handle)
147 : integer, intent(in) :: handle
148 : integer :: i
149 :
150 11 : if (handle < 1 .or. handle > max_colors_handles) return
151 :
152 : ! Free lookup table arrays
153 11 : if (allocated(colors_handles(handle)%lu_file_names)) &
154 1 : deallocate(colors_handles(handle)%lu_file_names)
155 11 : if (allocated(colors_handles(handle)%lu_logg)) &
156 1 : deallocate(colors_handles(handle)%lu_logg)
157 11 : if (allocated(colors_handles(handle)%lu_meta)) &
158 1 : deallocate(colors_handles(handle)%lu_meta)
159 11 : if (allocated(colors_handles(handle)%lu_teff)) &
160 1 : deallocate(colors_handles(handle)%lu_teff)
161 11 : colors_handles(handle)%lookup_loaded = .false.
162 :
163 : ! Free Vega SED arrays
164 11 : if (allocated(colors_handles(handle)%vega_wavelengths)) &
165 1 : deallocate(colors_handles(handle)%vega_wavelengths)
166 11 : if (allocated(colors_handles(handle)%vega_fluxes)) &
167 1 : deallocate(colors_handles(handle)%vega_fluxes)
168 11 : colors_handles(handle)%vega_loaded = .false.
169 :
170 : ! Free filter data arrays
171 11 : if (allocated(colors_handles(handle)%filters)) then
172 8 : do i = 1, size(colors_handles(handle)%filters)
173 7 : if (allocated(colors_handles(handle)%filters(i)%wavelengths)) &
174 7 : deallocate(colors_handles(handle)%filters(i)%wavelengths)
175 7 : if (allocated(colors_handles(handle)%filters(i)%transmission)) &
176 8 : deallocate(colors_handles(handle)%filters(i)%transmission)
177 : end do
178 8 : deallocate(colors_handles(handle)%filters)
179 : end if
180 11 : colors_handles(handle)%filters_loaded = .false.
181 :
182 : end subroutine free_colors_cache
183 :
184 8 : subroutine get_colors_ptr(handle, rq, ierr)
185 : integer, intent(in) :: handle
186 : type(Colors_General_Info), pointer, intent(out) :: rq
187 : integer, intent(out):: ierr
188 8 : if (handle < 1 .or. handle > max_colors_handles) then
189 0 : ierr = -1
190 0 : return
191 : end if
192 8 : rq => colors_handles(handle)
193 8 : ierr = 0
194 : end subroutine get_colors_ptr
195 :
196 1 : subroutine do_free_colors_tables
197 : integer :: i
198 :
199 : ! Free the filter names array
200 1 : if (allocated(color_filter_names)) deallocate(color_filter_names)
201 :
202 : ! Free cached data for all handles
203 11 : do i = 1, max_colors_handles
204 11 : call free_colors_cache(i)
205 : end do
206 :
207 1 : end subroutine do_free_colors_tables
208 :
209 0 : end module colors_def
|
