Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2025 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_history
21 :
22 : use const_def, only: dp, mesa_dir
23 : use utils_lib, only: mesa_error
24 : use colors_def, only: Colors_General_Info, get_colors_ptr, num_color_filters, color_filter_names
25 : use colors_utils, only: remove_dat
26 : use bolometric, only: calculate_bolometric
27 : use synthetic, only: calculate_synthetic
28 :
29 : implicit none
30 :
31 : contains
32 :
33 0 : integer function how_many_colors_history_columns(colors_handle)
34 : integer, intent(in) :: colors_handle
35 : integer :: num_cols, ierr
36 : type(Colors_General_Info), pointer :: colors_settings
37 :
38 : ierr = 0
39 0 : call get_colors_ptr(colors_handle, colors_settings, ierr)
40 0 : if (ierr /= 0) then
41 0 : write (*, *) 'failed in colors_ptr'
42 0 : num_cols = 0
43 0 : return
44 : end if
45 :
46 0 : if (.not. colors_settings%use_colors) then
47 : num_cols = 0
48 : else
49 0 : num_cols = 3 + num_color_filters
50 : end if
51 :
52 0 : how_many_colors_history_columns = num_cols
53 : end function how_many_colors_history_columns
54 :
55 0 : subroutine data_for_colors_history_columns( &
56 : t_eff, log_g, R, metallicity, &
57 0 : colors_handle, n, names, vals, ierr)
58 : real(dp), intent(in) :: t_eff, log_g, R, metallicity
59 : integer, intent(in) :: colors_handle, n
60 : character(len=80) :: names(n)
61 : real(dp) :: vals(n)
62 : integer, intent(out) :: ierr
63 :
64 : type(Colors_General_Info), pointer :: cs ! colors_settings
65 : integer :: i, filter_offset
66 : real(dp) :: d, bolometric_magnitude, bolometric_flux, interpolation_radius
67 : real(dp) :: zero_point
68 : character(len=256) :: sed_filepath, filter_name
69 : logical :: make_sed
70 :
71 0 : real(dp), dimension(:), allocatable :: wavelengths, fluxes
72 :
73 : ierr = 0
74 0 : call get_colors_ptr(colors_handle, cs, ierr)
75 0 : if (ierr /= 0) then
76 0 : write (*, *) 'failed in get_colors_ptr'
77 0 : return
78 : end if
79 :
80 : ! verify data was loaded at initialization
81 0 : if (.not. cs%lookup_loaded) then
82 0 : write (*, *) 'colors error: lookup table not loaded'
83 0 : ierr = -1
84 0 : return
85 : end if
86 0 : if (.not. cs%filters_loaded) then
87 0 : write (*, *) 'colors error: filter data not loaded'
88 0 : ierr = -1
89 0 : return
90 : end if
91 :
92 0 : d = cs%distance
93 0 : sed_filepath = trim(mesa_dir)//cs%stellar_atm
94 0 : make_sed = cs%make_csv
95 :
96 : ! Calculate bolometric magnitude using cached lookup table
97 : call calculate_bolometric(t_eff, log_g, metallicity, R, d, &
98 : bolometric_magnitude, bolometric_flux, wavelengths, fluxes, &
99 : sed_filepath, interpolation_radius, &
100 0 : cs%lu_file_names, cs%lu_teff, cs%lu_logg, cs%lu_meta)
101 :
102 0 : names(1) = "Mag_bol"
103 0 : vals(1) = bolometric_magnitude
104 0 : names(2) = "Flux_bol"
105 0 : vals(2) = bolometric_flux
106 0 : names(3) = "Interp_rad"
107 0 : vals(3) = interpolation_radius
108 0 : filter_offset = 3
109 :
110 0 : if (n == num_color_filters + filter_offset) then
111 0 : do i = 1, num_color_filters
112 0 : filter_name = trim(remove_dat(color_filter_names(i)))
113 0 : names(i + filter_offset) = filter_name
114 :
115 0 : if (t_eff >= 0 .and. metallicity >= 0) then
116 : ! Select precomputed zero-point based on magnitude system
117 0 : select case (trim(cs%mag_system))
118 : case ('VEGA', 'Vega', 'vega')
119 0 : zero_point = cs%filters(i)%vega_zero_point
120 : case ('AB', 'ab')
121 0 : zero_point = cs%filters(i)%ab_zero_point
122 : case ('ST', 'st')
123 0 : zero_point = cs%filters(i)%st_zero_point
124 : case default
125 0 : write (*, *) 'colors error: unknown magnitude system: ', trim(cs%mag_system)
126 0 : zero_point = -1.0_dp
127 : end select
128 :
129 : ! Calculate synthetic magnitude using cached filter data and precomputed zero-point
130 : vals(i + filter_offset) = calculate_synthetic(t_eff, log_g, metallicity, ierr, &
131 : wavelengths, fluxes, &
132 0 : cs%filters(i)%wavelengths, &
133 : cs%filters(i)%transmission, &
134 : zero_point, &
135 0 : color_filter_names(i), &
136 0 : make_sed, cs%colors_results_directory)
137 0 : if (ierr /= 0) vals(i + filter_offset) = -1.0_dp
138 : else
139 0 : vals(i + filter_offset) = -1.0_dp
140 0 : ierr = 1
141 : end if
142 : end do
143 : else
144 0 : ierr = 1
145 0 : call mesa_error(__FILE__, __LINE__, 'colors: data_for_colors_history_columns array size mismatch')
146 : end if
147 :
148 : ! Clean up allocated arrays from calculate_bolometric
149 0 : if (allocated(wavelengths)) deallocate(wavelengths)
150 0 : if (allocated(fluxes)) deallocate(fluxes)
151 :
152 0 : end subroutine data_for_colors_history_columns
153 :
154 : end module colors_history
|
