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
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, resolve_path
26 : use bolometric, only: calculate_bolometric
27 : use synthetic, only: calculate_synthetic
28 :
29 : implicit none
30 :
31 : contains
32 :
33 1 : 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 1 : call get_colors_ptr(colors_handle, colors_settings, ierr)
40 1 : if (ierr /= 0) then
41 0 : write (*, *) 'failed in colors_ptr'
42 0 : how_many_colors_history_columns = 0
43 0 : return
44 : end if
45 :
46 1 : if (.not. colors_settings%use_colors) then
47 : num_cols = 0
48 : else
49 1 : num_cols = 3 + num_color_filters
50 : end if
51 :
52 1 : how_many_colors_history_columns = num_cols
53 : end function how_many_colors_history_columns
54 :
55 15 : subroutine data_for_colors_history_columns( &
56 : t_eff, log_g, R, metallicity, model_number, &
57 15 : 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 : integer, intent(in) :: model_number
64 :
65 : type(Colors_General_Info), pointer :: cs ! colors_settings
66 : integer :: i, filter_offset
67 : real(dp) :: d, bolometric_magnitude, bolometric_flux, interpolation_radius
68 : real(dp) :: zero_point
69 : character(len=256) :: sed_filepath
70 : character(len=80) :: filter_name
71 : logical :: make_sed
72 :
73 15 : real(dp), dimension(:), allocatable :: wavelengths, fluxes
74 :
75 : ierr = 0
76 15 : call get_colors_ptr(colors_handle, cs, ierr)
77 15 : if (ierr /= 0) then
78 0 : write (*, *) 'failed in get_colors_ptr'
79 0 : return
80 : end if
81 :
82 : ! verify data was loaded at initialization
83 15 : if (.not. cs%lookup_loaded) then
84 0 : write (*, *) 'colors error: lookup table not loaded'
85 0 : ierr = -1
86 0 : return
87 : end if
88 15 : if (.not. cs%filters_loaded) then
89 0 : write (*, *) 'colors error: filter data not loaded'
90 0 : ierr = -1
91 0 : return
92 : end if
93 :
94 15 : d = cs%distance
95 15 : sed_filepath = trim(resolve_path(cs%stellar_atm))
96 15 : make_sed = cs%make_csv
97 :
98 : call calculate_bolometric(cs, t_eff, log_g, metallicity, R, d, &
99 : bolometric_magnitude, bolometric_flux, wavelengths, fluxes, &
100 15 : sed_filepath, interpolation_radius)
101 :
102 15 : names(1) = "Mag_bol"
103 15 : vals(1) = bolometric_magnitude
104 15 : names(2) = "Flux_bol"
105 15 : vals(2) = bolometric_flux
106 15 : names(3) = "Interp_rad"
107 15 : vals(3) = interpolation_radius
108 15 : filter_offset = 3
109 :
110 15 : if (n == num_color_filters + filter_offset) then
111 120 : do i = 1, num_color_filters
112 105 : filter_name = trim(remove_dat(color_filter_names(i)))
113 105 : names(i + filter_offset) = filter_name
114 :
115 : ! Negative [M/H] values are valid for metal-poor atmosphere grids.
116 : ! so we do not apply a limit on the "metallicity" parameter.
117 120 : if (t_eff >= 0) then
118 : ! Select precomputed zero-point based on magnitude system
119 210 : select case (trim(cs%mag_system))
120 : case ('VEGA', 'Vega', 'vega')
121 105 : zero_point = cs%filters(i)%vega_zero_point
122 : case ('AB', 'ab')
123 0 : zero_point = cs%filters(i)%ab_zero_point
124 : case ('ST', 'st')
125 0 : zero_point = cs%filters(i)%st_zero_point
126 : case default
127 0 : write (*, *) 'colors error: unknown magnitude system: ', trim(cs%mag_system)
128 105 : zero_point = -1.0_dp
129 : end select
130 :
131 : vals(i + filter_offset) = calculate_synthetic(t_eff, log_g, metallicity, ierr, &
132 : wavelengths, fluxes, &
133 : cs%filters(i)%wavelengths, &
134 : cs%filters(i)%transmission, &
135 : zero_point, &
136 : color_filter_names(i), &
137 : make_sed, cs%sed_per_model, &
138 105 : cs%colors_results_directory, model_number)
139 :
140 105 : if (ierr /= 0) vals(i + filter_offset) = -1.0_dp
141 : else
142 0 : vals(i + filter_offset) = -1.0_dp
143 0 : ierr = 1
144 : end if
145 : end do
146 : else
147 0 : ierr = 1
148 0 : call mesa_error(__FILE__, __LINE__, 'colors: data_for_colors_history_columns array size mismatch')
149 : end if
150 :
151 : ! clean up
152 15 : if (allocated(wavelengths)) deallocate (wavelengths)
153 15 : if (allocated(fluxes)) deallocate (fluxes)
154 :
155 15 : end subroutine data_for_colors_history_columns
156 :
157 : end module colors_history
|
