Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2010 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 star_lib ! this is the procedure interface to mesa/star.
21 :
22 : use const_def, only: dp, i8
23 : use star_def, only: star_ptr, star_info, maxlen_profile_column_name
24 : use utils_lib, only: mesa_error
25 :
26 : use pulse, only: &
27 : star_export_pulse_data => export_pulse_data, &
28 : star_get_pulse_data => get_pulse_data, &
29 : star_write_pulse_data => write_pulse_data
30 :
31 : use overshoot_utils, only: &
32 : star_eval_conv_bdy_k => eval_conv_bdy_k, &
33 : star_eval_conv_bdy_r => eval_conv_bdy_r, &
34 : star_eval_conv_bdy_Hp => eval_conv_bdy_Hp, &
35 : star_eval_over_bdy_params => eval_over_bdy_params
36 :
37 : use auto_diff_support, only: & ! for variables of type auto_diff_real_star_order1
38 : shift_p1, shift_m1, & ! my_val_m1 = shift_m1(get_my_val(s,k-1)) for use in terms going into equation at k
39 : wrap_T_m1, wrap_T_00, wrap_T_p1, & ! for s% T
40 : wrap_lnT_m1, wrap_lnT_00, wrap_lnT_p1, & ! for s% lnT
41 : wrap_d_m1, wrap_d_00, wrap_d_p1, & ! ! values from s% rho
42 : wrap_lnd_m1, wrap_lnd_00, wrap_lnd_p1, & ! values from s% lnd
43 : wrap_w_m1, wrap_w_00, wrap_w_p1, & ! values from s% w
44 : wrap_kap_m1, wrap_kap_00, wrap_kap_p1, & ! values from s% opacity
45 : wrap_s_m1, wrap_s_00, wrap_s_p1, & ! values from s% entropy
46 : wrap_e_m1, wrap_e_00, wrap_e_p1, & ! values from s% energy
47 : wrap_Peos_m1, wrap_Peos_00, wrap_Peos_p1, & ! values from s% Peos
48 : wrap_lnPeos_m1, wrap_lnPeos_00, wrap_lnPeos_p1, & ! values from s% lnPeos
49 : wrap_ChiRho_m1, wrap_ChiRho_00, wrap_ChiRho_p1, & ! values from s% ChiRho
50 : wrap_ChiT_m1, wrap_ChiT_00, wrap_ChiT_p1, & ! values from s% ChiT
51 : wrap_Cp_m1, wrap_Cp_00, wrap_Cp_p1, & ! values from s% Cp
52 : wrap_gamma1_m1, wrap_gamma1_00, wrap_gamma1_p1, & ! values from s% gamma1
53 : wrap_L_m1, wrap_L_00, wrap_L_p1, & ! values from s% L
54 : wrap_r_m1, wrap_r_00, wrap_r_p1, & ! values from s% r
55 : wrap_lnR_m1, wrap_lnR_00, wrap_lnR_p1, & ! values from s% lnr
56 : wrap_v_m1, wrap_v_00, wrap_v_p1, & ! Riemann or non-Riemann velocity at face, s% v or s% u_face
57 : wrap_u_m1, wrap_u_00, wrap_u_p1, & ! Riemann cell velocity s% u
58 : wrap_w_div_wc_m1, wrap_w_div_wc_00, wrap_w_div_wc_p1, & ! Riemann cell velocity s% u
59 : wrap_jrot_m1, wrap_jrot_00, wrap_jrot_p1, & ! Riemann cell velocity s% u
60 : ! the following check the flag using_velocity_time_centering
61 : wrap_opt_time_center_r_m1, wrap_opt_time_center_r_00, wrap_opt_time_center_r_p1, &
62 : wrap_opt_time_center_v_m1, wrap_opt_time_center_v_00, wrap_opt_time_center_v_p1
63 :
64 : use star_utils, only: &
65 : star_conv_time_scale => conv_time_scale, &
66 : star_QHSE_time_scale => QHSE_time_scale, &
67 : star_eps_nuc_time_scale => eps_nuc_time_scale, &
68 : star_cooling_time_scale => cooling_time_scale, &
69 : star_kh_time_scale => eval_kh_timescale, &
70 : star_weighted_smoothing => weighted_smoothing, &
71 : star_threshold_smoothing => threshold_smoothing
72 :
73 : implicit none
74 :
75 : contains
76 :
77 : ! allocate data structures for a star and returns a handle.
78 2 : subroutine alloc_star(id, ierr)
79 : use init, only: alloc_star_data
80 : integer, intent(out) :: id, ierr
81 2 : call alloc_star_data(id, ierr)
82 2 : end subroutine alloc_star
83 :
84 :
85 0 : subroutine init_starting_star_data(s, ierr) ! this is done when alloc_star
86 : ! but if you are reusing the star data (and not calling alloc_star)
87 : ! then call this to get things initialized.
88 2 : use init, only: set_starting_star_data
89 :
90 : type (star_info), pointer :: s
91 : integer, intent(out) :: ierr
92 0 : call set_starting_star_data(s, ierr)
93 0 : end subroutine init_starting_star_data
94 :
95 : ! call this when you are finished with the star.
96 1 : subroutine free_star(id, ierr)
97 0 : use alloc, only: free_star_data
98 : ! frees the handle and all associated data
99 : integer, intent(in) :: id
100 : integer, intent(out) :: ierr
101 :
102 1 : call star_shutdown_pgstar(id, ierr)
103 1 : call star_dealloc_extras(id)
104 1 : call free_star_data(id, ierr)
105 1 : end subroutine free_star
106 :
107 :
108 1 : subroutine read_star_job(s, filename, ierr)
109 1 : use star_private_def
110 : use star_job_ctrls_io, only: do_read_star_job
111 : type (star_info), pointer :: s
112 : character(*), intent(in) :: filename
113 : integer, intent(out) :: ierr
114 1 : call do_read_star_job(s, filename, ierr)
115 1 : end subroutine read_star_job
116 :
117 0 : subroutine read_star_job_id(id, filename, ierr)
118 1 : use star_private_def
119 : use star_job_ctrls_io, only: do_read_star_job
120 : type (star_info), pointer :: s
121 : character(*), intent(in) :: filename
122 : integer, intent(out) :: ierr
123 : integer, intent(in) :: id
124 0 : call star_ptr(id, s, ierr)
125 0 : if (ierr/=0) return
126 0 : call read_star_job(s, filename, ierr)
127 0 : end subroutine read_star_job_id
128 :
129 :
130 0 : subroutine write_star_job(s, filename, ierr)
131 0 : use star_private_def
132 : use star_job_ctrls_io, only: do_write_star_job
133 : type (star_info), pointer :: s
134 : character(*), intent(in) :: filename
135 : integer, intent(out) :: ierr
136 0 : call do_write_star_job(s, filename, ierr)
137 0 : end subroutine write_star_job
138 :
139 0 : subroutine write_star_job_id(id, filename, ierr)
140 0 : use star_private_def
141 : use star_job_ctrls_io, only: do_write_star_job
142 : integer, intent(in) :: id
143 : type (star_info), pointer :: s
144 : character(*), intent(in) :: filename
145 : integer, intent(out) :: ierr
146 0 : call star_ptr(id, s, ierr)
147 0 : if (ierr/=0) return
148 0 : call write_star_job(s, filename, ierr)
149 0 : end subroutine write_star_job_id
150 :
151 :
152 : ! call this after read_star_job.
153 : ! this sets starlib parameters that apply to all stars.
154 : ! okay to do extra calls on this; only 1st call is used.
155 1 : subroutine starlib_init(s, ierr)
156 : type (star_info), pointer :: s
157 : integer, intent(out) :: ierr
158 : call do_starlib_init( &
159 : s% job% mesa_dir, s% job% chem_isotopes_filename, &
160 : s% job% net_reaction_filename, s% job% jina_reaclib_filename, &
161 : s% job% use_suzuki_weak_rates, &
162 : s% job% use_special_weak_rates, &
163 : s% job% special_weak_states_file, &
164 : s% job% special_weak_transitions_file, &
165 : s% job% jina_reaclib_min_T9, &
166 : s% job% rate_tables_dir, s% job% rate_cache_suffix, &
167 : s% job% ionization_file_prefix, s% job% ionization_Z1_suffix, &
168 : s% job% eosDT_cache_dir, &
169 : s% job% ionization_cache_dir, s% job% kap_cache_dir, s% job% rates_cache_dir, &
170 1 : ierr)
171 0 : end subroutine starlib_init
172 :
173 :
174 1 : subroutine do_starlib_init( &
175 : my_mesa_dir, &
176 : chem_isotopes_filename, &
177 : net_reaction_filename, jina_reaclib_filename, &
178 : use_suzuki_weak_rates, &
179 : use_special_weak_rates, special_weak_states_file, special_weak_transitions_file, &
180 : reaclib_min_T9, &
181 : rate_tables_dir, rates_cache_suffix, &
182 : ionization_file_prefix, ionization_Z1_suffix, &
183 : eosDT_cache_dir, &
184 : ionization_cache_dir, kap_cache_dir, rates_cache_dir, &
185 : ierr)
186 : use init, only: do_star_init
187 : character (len=*), intent(in) :: &
188 : my_mesa_dir, chem_isotopes_filename, net_reaction_filename, &
189 : jina_reaclib_filename, rate_tables_dir, &
190 : special_weak_states_file, special_weak_transitions_file, &
191 : rates_cache_suffix, &
192 : ionization_file_prefix, ionization_Z1_suffix, &
193 : eosDT_cache_dir, &
194 : ionization_cache_dir, kap_cache_dir, rates_cache_dir
195 : real(dp), intent(in) :: &
196 : reaclib_min_T9
197 : logical, intent(in) :: use_suzuki_weak_rates, use_special_weak_rates
198 : integer, intent(out) :: ierr
199 : call do_star_init( &
200 : my_mesa_dir, &
201 : chem_isotopes_filename, &
202 : net_reaction_filename, jina_reaclib_filename, &
203 : use_suzuki_weak_rates, &
204 : use_special_weak_rates, special_weak_states_file, special_weak_transitions_file, &
205 : reaclib_min_T9, &
206 : rate_tables_dir, rates_cache_suffix, &
207 : ionization_file_prefix, ionization_Z1_suffix, &
208 : eosDT_cache_dir, &
209 : ionization_cache_dir, kap_cache_dir, rates_cache_dir, &
210 1 : ierr)
211 1 : end subroutine do_starlib_init
212 :
213 :
214 : ! call this when you are done.
215 1 : subroutine starlib_shutdown
216 1 : use init, only: do_starlib_shutdown
217 1 : call do_starlib_shutdown
218 1 : end subroutine starlib_shutdown
219 :
220 :
221 : ! if you want direct access to the star data structure,
222 : ! then you need to convert the handle to a pointer.
223 : ! use the routine star_ptr defined in star_def.
224 :
225 :
226 : ! once you've allocated a star, you need to initialize it.
227 : ! this is done in two stages: first you set the various control parameters
228 : ! (using star_setup), and then you actually create the model
229 : ! (using star_load).
230 :
231 :
232 : ! logs and profiles are by default written to the directory named "logs_and_profiles",
233 : ! but you can change that if you'd like by calling this routine before calling star_setup.
234 0 : subroutine set_dir_for_logs_and_profiles(id, dir_name, ierr)
235 : integer, intent(in) :: id
236 : character (len=*), intent(in) :: dir_name
237 : integer, intent(out) :: ierr
238 : type (star_info), pointer :: s
239 0 : call star_ptr(id, s, ierr)
240 0 : if (ierr /= 0) return
241 0 : s% log_directory = dir_name
242 1 : end subroutine set_dir_for_logs_and_profiles
243 :
244 :
245 1 : subroutine star_set_history_columns(id, history_columns_file, report, ierr)
246 : use history_specs, only: set_history_columns
247 : integer, intent(in) :: id
248 : character (len=*), intent(in) :: history_columns_file
249 : logical, intent(in) :: report
250 : integer, intent(out) :: ierr
251 1 : call set_history_columns(id, history_columns_file, report, ierr)
252 1 : end subroutine star_set_history_columns
253 :
254 :
255 0 : integer function star_get_history_column_id(cname)
256 : ! returns id for the history column if there is a matching name
257 : ! returns 0 otherwise.
258 1 : use star_history_def, only: do_get_history_id
259 : character (len=*), intent(in) :: cname
260 0 : star_get_history_column_id = do_get_history_id(cname)
261 0 : end function star_get_history_column_id
262 :
263 :
264 1 : subroutine star_set_profile_columns(id, profile_columns_file, report, ierr)
265 0 : use profile, only: set_profile_columns
266 : integer, intent(in) :: id
267 : character (len=*), intent(in) :: profile_columns_file
268 : logical, intent(in) :: report
269 : integer, intent(out) :: ierr
270 1 : call set_profile_columns(id, profile_columns_file, report, ierr)
271 1 : end subroutine star_set_profile_columns
272 :
273 :
274 : ! read a "namelist" file and setup parameters for the star.
275 1 : subroutine star_setup(id, inlist, ierr)
276 1 : use ctrls_io, only: do_one_setup
277 : integer, intent(in) :: id
278 : character (len=*), intent(in) :: inlist ! can be blank meaning no inlist file
279 : integer, intent(out) :: ierr ! 0 means AOK.
280 1 : call do_one_setup(id, inlist, ierr)
281 1 : end subroutine star_setup
282 :
283 :
284 : ! okay to call this more than once; only 1st call does the work.
285 1 : subroutine star_set_kap_and_eos_handles(id, ierr)
286 1 : use init, only: set_kap_and_eos_handles
287 : integer, intent(in) :: id
288 : integer, intent(out) :: ierr ! 0 means AOK.
289 1 : call set_kap_and_eos_handles(id, ierr)
290 1 : end subroutine star_set_kap_and_eos_handles
291 :
292 :
293 1 : subroutine star_set_colors_handles(id, ierr)
294 1 : use init, only: set_colors_handles
295 : integer, intent(in) :: id
296 : integer, intent(out) :: ierr ! 0 means AOK.
297 1 : call set_colors_handles(id, ierr)
298 1 : end subroutine star_set_colors_handles
299 :
300 :
301 0 : subroutine star_set_net(id, new_net_name, ierr)
302 1 : use net, only: set_net
303 : integer, intent(in) :: id
304 : character (len=*), intent(in) :: new_net_name
305 : integer, intent(out) :: ierr
306 : type (star_info), pointer :: s
307 0 : call star_ptr(id, s, ierr)
308 0 : if (ierr /= 0) return
309 0 : s% net_name = new_net_name
310 0 : call set_net(s, new_net_name, ierr)
311 0 : end subroutine star_set_net
312 :
313 :
314 0 : subroutine star_set_var_info(id, ierr)
315 0 : use alloc, only: set_var_info
316 : integer, intent(in) :: id
317 : integer, intent(out) :: ierr
318 : type (star_info), pointer :: s
319 0 : call star_ptr(id, s, ierr)
320 0 : if (ierr /= 0) return
321 0 : call set_var_info(s, ierr)
322 0 : end subroutine star_set_var_info
323 :
324 :
325 0 : subroutine star_set_chem_names(id, ierr)
326 0 : use alloc, only: set_chem_names
327 : integer, intent(in) :: id
328 : integer, intent(out) :: ierr
329 : type (star_info), pointer :: s
330 0 : call star_ptr(id, s, ierr)
331 0 : if (ierr /= 0) return
332 0 : call set_chem_names(s)
333 0 : end subroutine star_set_chem_names
334 :
335 :
336 0 : subroutine star_allocate_arrays(id, ierr)
337 0 : use alloc, only: allocate_star_info_arrays
338 : integer, intent(in) :: id
339 : integer, intent(out) :: ierr
340 : type (star_info), pointer :: s
341 0 : call star_ptr(id, s, ierr)
342 0 : if (ierr /= 0) return
343 0 : call allocate_star_info_arrays(s, ierr)
344 0 : end subroutine star_allocate_arrays
345 :
346 :
347 : ! if there is a file called 'restart_photo', then it will be used to restart.
348 : ! otherwise, create a new model with arbitrary mass and metallicity
349 : ! as determined by initial_mass and initial_z in the star_info structure.
350 : ! reads prebuilt initial models from mesa/data/star_data/starting_models.
351 : ! when star_load returns, the variables in star_def will have been set.
352 : ! in particular, model_number will be 0 for a fresh start,
353 : ! and it will be greater than 0 for a restart.
354 1 : subroutine star_load_zams(id, ierr)
355 0 : use init, only: load_zams_model
356 : integer, intent(in) :: id
357 : integer, intent(out) :: ierr
358 : ierr = 0
359 1 : call load_zams_model(id, ierr)
360 1 : end subroutine star_load_zams
361 :
362 :
363 : ! you can create a "pre-main-sequence" approximation
364 : ! that has not started nuclear burning yet.
365 : ! the following routine will construct a protostar
366 : ! with uniform composition and center temperature T_c.
367 : ! the initial_mass and initial_z are specified by the
368 : ! usual control parameters (e.g., in the inlist file).
369 : ! T_c must be less than 10^6 so that nuclear burning can be ignored.
370 : ! rho_c will be adjusted to fit the required mass.
371 0 : subroutine star_create_pre_ms_model( &
372 : id, T_c, guess_rho_c, d_log10_P, logT_surf_limit, &
373 : logP_surf_limit, pre_ms_initial_zfracs, &
374 : dump_missing_metals_into_heaviest, &
375 : change_net, new_net_name, &
376 : pre_ms_relax_num_steps, ierr)
377 1 : use init, only: create_pre_ms_model
378 :
379 : integer, intent(in) :: id
380 : real(dp), intent(in) :: T_c
381 : ! optional initial center temperature
382 : ! set to 0 to use default
383 : real(dp), intent(in) :: guess_rho_c
384 : ! optional initial guess for center density
385 : ! set to 0 to use default
386 : real(dp), intent(in) :: d_log10_P
387 : ! standard point spacing in initial model is d_log10_P
388 : ! set to 0 to use default
389 : ! model construction is from inside out and stops when at either of the following.
390 : real(dp), intent(in) :: logT_surf_limit
391 : ! set to 0 to use default
392 : real(dp), intent(in) :: logP_surf_limit
393 : ! set to 0 to use default
394 : integer, intent(in) :: pre_ms_initial_zfracs, pre_ms_relax_num_steps
395 : logical, intent(in) :: dump_missing_metals_into_heaviest, change_net
396 : character(len=*), intent(in) :: new_net_name
397 : integer, intent(out) :: ierr
398 : type (star_info), pointer :: s
399 : ierr = 0
400 0 : call star_ptr(id, s, ierr)
401 0 : if (ierr /= 0) return
402 0 : s% pre_ms_T_c = T_c
403 0 : s% pre_ms_guess_rho_c = guess_rho_c
404 0 : s% pre_ms_d_log10_P = d_log10_P
405 0 : s% pre_ms_logT_surf_limit = logT_surf_limit
406 0 : s% pre_ms_logP_surf_limit = logP_surf_limit
407 0 : s% pre_ms_initial_zfracs = pre_ms_initial_zfracs
408 0 : s% pre_ms_change_net = change_net
409 0 : s% pre_ms_new_net_name = new_net_name
410 0 : s% pre_ms_relax_num_steps = pre_ms_relax_num_steps
411 0 : s% pre_ms_dump_missing_heaviest = dump_missing_metals_into_heaviest
412 0 : call create_pre_ms_model(id, ierr)
413 0 : if (ierr /= 0) return
414 0 : end subroutine star_create_pre_ms_model
415 :
416 : ! you can create an initial model for given mass and radius.
417 0 : subroutine star_create_initial_model(id, &
418 : radius_in_cm_for_create_initial_model, &
419 : mass_in_gm_for_create_initial_model, &
420 : center_logP_1st_try_for_create_initial_model, &
421 : entropy_1st_try_for_create_initial_model, &
422 : max_tries_for_create_initial_model, &
423 : abs_e01_tolerance_for_create_initial_model, &
424 : abs_e02_tolerance_for_create_initial_model, &
425 : initial_zfracs, dump_missing_metals_into_heaviest, change_net, new_net_name, &
426 : initial_model_relax_num_steps, initial_model_eps, ierr)
427 0 : use init, only: create_initial_model
428 : integer, intent(in) :: id
429 : real(dp), intent(in) :: radius_in_cm_for_create_initial_model, &
430 : mass_in_gm_for_create_initial_model, &
431 : center_logP_1st_try_for_create_initial_model, &
432 : entropy_1st_try_for_create_initial_model, &
433 : abs_e01_tolerance_for_create_initial_model, &
434 : abs_e02_tolerance_for_create_initial_model
435 : integer, intent(in) :: &
436 : initial_zfracs, initial_model_relax_num_steps, max_tries_for_create_initial_model
437 : logical, intent(in) :: dump_missing_metals_into_heaviest, change_net
438 : character(len=*), intent(in) :: new_net_name
439 : real(dp), intent(in) :: initial_model_eps
440 : integer, intent(out) :: ierr
441 : type (star_info), pointer :: s
442 : ierr = 0
443 0 : call star_ptr(id, s, ierr)
444 0 : if (ierr /= 0) return
445 0 : s% radius_in_cm_for_create_initial_model = radius_in_cm_for_create_initial_model
446 0 : s% mass_in_gm_for_create_initial_model = mass_in_gm_for_create_initial_model
447 : s% center_logP_1st_try_for_create_initial_model = &
448 0 : center_logP_1st_try_for_create_initial_model
449 : s% entropy_1st_try_for_create_initial_model = &
450 0 : entropy_1st_try_for_create_initial_model
451 0 : s% max_tries_for_create_initial_model = max_tries_for_create_initial_model
452 : s% abs_e01_tolerance_for_create_initial_model = &
453 0 : abs_e01_tolerance_for_create_initial_model
454 : s% abs_e02_tolerance_for_create_initial_model = &
455 0 : abs_e02_tolerance_for_create_initial_model
456 0 : s% initial_zfracs_for_create_initial_model = initial_zfracs
457 0 : s% initial_model_relax_num_steps = initial_model_relax_num_steps
458 0 : s% initial_model_eps = initial_model_eps
459 0 : s% initial_model_change_net = change_net
460 0 : s% initial_model_new_net_name = new_net_name
461 0 : s% initial_dump_missing_heaviest = dump_missing_metals_into_heaviest
462 0 : call create_initial_model(id, ierr)
463 0 : if (ierr /= 0) return
464 0 : end subroutine star_create_initial_model
465 :
466 :
467 1 : logical function doing_a_restart(restart_filename)
468 0 : use init, only: doing_restart
469 : character (len=*) :: restart_filename
470 1 : doing_a_restart = doing_restart(restart_filename)
471 1 : end function doing_a_restart
472 :
473 :
474 0 : subroutine star_load_restart_photo(id, restart_filename, ierr)
475 1 : use init, only: load_restart_photo
476 : integer, intent(in) :: id
477 : character (len=*), intent(in) :: restart_filename
478 : integer, intent(out) :: ierr
479 0 : call load_restart_photo(id, restart_filename, ierr)
480 0 : end subroutine star_load_restart_photo
481 :
482 :
483 0 : subroutine star_write_model(id, filename, ierr)
484 0 : use write_model, only: do_write_model
485 : integer, intent(in) :: id
486 : character (len=*), intent(in) :: filename
487 : integer, intent(out) :: ierr
488 0 : call do_write_model(id, filename, ierr)
489 0 : end subroutine star_write_model
490 :
491 :
492 1 : subroutine star_write_photo(id, fname, ierr)
493 0 : use evolve_support, only: output, output_to_file
494 : integer, intent(in) :: id
495 : character (len=*), intent(in) :: fname
496 : integer, intent(out) :: ierr
497 1 : if (len_trim(fname) == 0) then
498 1 : call output(id, ierr)
499 : else
500 0 : call output_to_file(fname, id, ierr)
501 : end if
502 1 : end subroutine star_write_photo
503 :
504 :
505 0 : subroutine star_read_model(id, model_fname, ierr)
506 1 : use init, only: load_saved_model
507 : integer, intent(in) :: id
508 : character (len=*), intent(in) :: model_fname
509 : integer, intent(out) :: ierr
510 0 : call load_saved_model(id, model_fname, ierr)
511 0 : end subroutine star_read_model
512 :
513 :
514 0 : subroutine star_number_from_saved_model(fname, model_number, ierr)
515 0 : use read_model, only: do_read_saved_model_number
516 : character (len=*), intent(in) :: fname ! filename for the saved model
517 : integer, intent(inout) :: model_number
518 : ! set only if this property is present in file
519 : integer, intent(out) :: ierr
520 0 : call do_read_saved_model_number(fname, model_number, ierr)
521 0 : end subroutine star_number_from_saved_model
522 :
523 :
524 0 : subroutine star_age_from_saved_model(fname, star_age, ierr)
525 0 : use read_model, only: do_read_saved_model_age
526 : character (len=*), intent(in) :: fname ! filename for the saved model
527 : real(dp), intent(inout) :: star_age
528 : ! set only if this property is present in file
529 : integer, intent(out) :: ierr
530 0 : call do_read_saved_model_age(fname, star_age, ierr)
531 0 : end subroutine star_age_from_saved_model
532 :
533 :
534 : ! after you've created a starting model, you're ready to evolve it.
535 : ! this process is done one step at a time by calling star_evolve_step.
536 :
537 :
538 : ! this routine takes one step in the evolution.
539 : ! when it returns successfully (i.e, with value = keep_going), the data
540 : ! describing the new model can be found in the variables defined in star_def.
541 11 : integer function star_evolve_step(id, first_try)
542 : ! returns either keep_going, redo, retry, or terminate
543 0 : use star_def, only: terminate, keep_going
544 : use star_utils, only: start_time, update_time
545 : integer, intent(in) :: id
546 : logical, intent(in) :: first_try
547 : ! true on the first try to take this step
548 : ! false if this is a repeat for a retry
549 : type (star_info), pointer :: s
550 : integer :: ierr
551 : integer(i8) :: time0
552 11 : real(dp) :: total
553 11 : star_evolve_step = terminate
554 : ierr = 0
555 11 : call star_ptr(id, s, ierr)
556 11 : if (ierr /= 0) return
557 11 : if (s% doing_timing) call start_time(s, time0, total)
558 11 : star_evolve_step = star_evolve_step_part1(id, first_try)
559 11 : if (star_evolve_step == keep_going) &
560 11 : star_evolve_step = star_evolve_step_part2(id, first_try)
561 11 : if (s% doing_timing) call update_time(s, time0, total, s% time_evolve_step)
562 11 : end function star_evolve_step
563 :
564 : ! individual functions to evolve each of the parts of star_evolve_step
565 11 : integer function star_evolve_step_part1(id, first_try)
566 11 : use star_def, only: keep_going, redo, retry, terminate
567 : use evolve, only: do_evolve_step_part1
568 : integer, intent(in) :: id
569 : logical, intent(in) :: first_try
570 : type (star_info), pointer :: s
571 : integer :: ierr
572 11 : star_evolve_step_part1 = terminate
573 : ierr = 0
574 11 : call star_ptr(id, s, ierr)
575 11 : if (ierr /= 0) return
576 11 : star_evolve_step_part1 = do_evolve_step_part1(id, first_try)
577 11 : end function star_evolve_step_part1
578 :
579 11 : integer function star_evolve_step_part2(id, first_try)
580 11 : use star_def, only: keep_going, redo, retry, terminate
581 : use evolve, only: do_evolve_step_part2
582 : integer, intent(in) :: id
583 : logical, intent(in) :: first_try
584 : type (star_info), pointer :: s
585 : integer :: ierr
586 11 : star_evolve_step_part2 = terminate
587 : ierr = 0
588 11 : call star_ptr(id, s, ierr)
589 11 : if (ierr /= 0) return
590 11 : star_evolve_step_part2 = do_evolve_step_part2(id, first_try)
591 11 : end function star_evolve_step_part2
592 :
593 :
594 : ! once the step is completed, call the following routines to check the
595 : ! new model and pick the next timestep.
596 :
597 :
598 : ! this is the standard routine for checking the model after each step.
599 : ! it takes care of things such as writing logs and profiles.
600 11 : integer function star_check_model(id)
601 : ! returns either keep_going, redo, retry, or terminate.
602 11 : use do_one_utils, only: do_one_check_model
603 : integer, intent(in) :: id
604 11 : star_check_model = do_one_check_model(id)
605 11 : end function star_check_model
606 :
607 :
608 : ! this is the standard routine for checking if have reached some limit
609 : ! such as max_age, max_model_number, psi_center_limit, h1_center_limit, etc.
610 0 : integer function star_check_limits(id)
611 : ! returns either keep_going or terminate.
612 11 : use do_one_utils, only: do_check_limits
613 : integer, intent(in) :: id
614 0 : star_check_limits = do_check_limits(id)
615 0 : end function star_check_limits
616 :
617 :
618 : ! this routine inspects the new model and picks a new timestep.
619 : ! if it decides that the changes in the new model are too great,
620 11 : integer function star_pick_next_timestep(id)
621 : ! returns either keep_going, redo, retry, or terminate.
622 0 : use evolve, only: pick_next_timestep
623 : integer, intent(in) :: id
624 11 : star_pick_next_timestep = pick_next_timestep(id)
625 11 : end function star_pick_next_timestep
626 :
627 :
628 : ! at the end of a successful step, call this routine to take care of
629 : ! things such as writing log files or saving a "snapshot" for restarts.
630 11 : integer function star_finish_step(id, ierr)
631 : ! returns either keep_going, redo, retry, or terminate.
632 11 : use evolve, only: finish_step
633 : integer, intent(in) :: id
634 : integer, intent(out) :: ierr
635 11 : star_finish_step = finish_step(id, ierr)
636 11 : end function star_finish_step
637 :
638 :
639 : ! this routine needs to be called before you do a redo.
640 0 : integer function star_prepare_to_redo(id)
641 : ! returns either keep_going, retry, or terminate.
642 11 : use evolve, only: prepare_to_redo
643 : integer, intent(in) :: id
644 0 : star_prepare_to_redo = prepare_to_redo(id)
645 0 : end function star_prepare_to_redo
646 :
647 :
648 : ! once in a while an attempted step will fail, and you'll need to retry it
649 : ! with a smaller timestep or resort to backing up to a previous model.
650 :
651 :
652 : ! this routine needs to be called before you do a retry.
653 0 : integer function star_prepare_to_retry(id)
654 : ! returns either keep_going, or terminate.
655 0 : use evolve, only: prepare_to_retry
656 : integer, intent(in) :: id
657 0 : star_prepare_to_retry = prepare_to_retry(id)
658 0 : end function star_prepare_to_retry
659 :
660 : ! typically, after the namelist controls file has been read by the star setup routine,
661 : ! you won't need to do anything else with it. But in case you want
662 : ! to read or write a control file at other times, here are the routines to do it.
663 0 : subroutine star_read_controls(id, filename, ierr)
664 0 : use ctrls_io, only: read_controls
665 : integer, intent(in) :: id
666 : character(*), intent(in) :: filename
667 : integer, intent(out) :: ierr
668 0 : call read_controls(id, filename, ierr)
669 0 : end subroutine star_read_controls
670 :
671 :
672 0 : subroutine star_write_controls(id, filename, ierr)
673 0 : use ctrls_io, only: write_controls
674 : integer, intent(in) :: id
675 : character(*), intent(in) :: filename
676 : integer, intent(out) :: ierr
677 : type (star_info), pointer :: s
678 0 : call star_ptr(id, s, ierr)
679 0 : if (ierr /= 0) return
680 0 : call write_controls(s, filename, ierr)
681 0 : end subroutine star_write_controls
682 :
683 0 : subroutine star_build_atm(s, L, R, Teff, M, cgrav, ierr)
684 : ! sets s% atm_structure_num_pts and s% atm_structure
685 0 : use atm_support
686 : type (star_info), pointer :: s
687 : real(dp), intent(in) :: L, R, Teff, M, cgrav
688 : integer, intent(out) :: ierr
689 0 : call build_atm(s, L, R, Teff, M, cgrav, ierr)
690 0 : end subroutine star_build_atm
691 :
692 :
693 : ! normally, "snapshots" for restarts will be saved automatically according
694 : ! to the value of the photo_interval parameter. but if you want to
695 : ! do it yourself, you can call the following routine.
696 0 : subroutine star_save_for_restart(id, filename, ierr)
697 0 : use evolve_support, only: output_to_file
698 : integer, intent(in) :: id
699 : character (len=*) :: filename
700 : integer, intent(out) :: ierr
701 0 : call output_to_file(filename, id, ierr)
702 0 : end subroutine star_save_for_restart
703 :
704 :
705 0 : integer function num_standard_history_columns(s) ! not including any extra columns
706 : type (star_info), pointer :: s
707 0 : num_standard_history_columns = size(s% history_column_spec, dim=1)
708 0 : end function num_standard_history_columns
709 :
710 :
711 : ! set "history info" in star data
712 0 : subroutine get_data_for_history_columns(s, &
713 : ierr)
714 : use history, only: do_get_data_for_history_columns
715 : type (star_info), pointer :: s
716 : integer, intent(out) :: ierr
717 : call do_get_data_for_history_columns( &
718 : s, &
719 0 : ierr)
720 0 : end subroutine get_data_for_history_columns
721 :
722 :
723 0 : integer function num_standard_profile_columns(s) ! not including extra profile columns
724 0 : use profile, only: do_get_num_standard_profile_columns
725 : type (star_info), pointer :: s
726 0 : num_standard_profile_columns = do_get_num_standard_profile_columns(s)
727 0 : end function num_standard_profile_columns
728 :
729 :
730 0 : subroutine get_data_for_profile_columns(s, &
731 : nz, names, vals, is_int, ierr)
732 0 : use profile, only: do_get_data_for_profile_columns
733 : type (star_info), pointer :: s
734 : integer, intent(in) :: nz
735 : ! note: it is the caller's job to allocate names and vals before calling
736 : ! and deallocate them when done.
737 : ! see num_standard_profile_columns function
738 : character (len=maxlen_profile_column_name), pointer :: names(:) ! (num_columns)
739 : real(dp), pointer :: vals(:,:) ! (nz,num_columns)
740 : logical, pointer :: is_int(:) ! (num_columns) true iff the values in the column are integers
741 : integer, intent(out) :: ierr
742 : call do_get_data_for_profile_columns(s, nz, &
743 0 : names, vals, is_int, ierr)
744 0 : end subroutine get_data_for_profile_columns
745 :
746 :
747 : ! you may want to have some data automatically saved and restored along with
748 : ! the rest of the information in a snapshot. you can do it by using the following routines.
749 : ! for example, you can check the model_number after star_load returns to see if you
750 : ! are doing a fresh start or a restart. If the model_number is 0, it is a fresh start and
751 : ! you can call star_alloc_extras to create the arrays and then call star_extra_arrays to
752 : ! get pointers to them. The contents of the arrays will be saved as part of any future snapshot.
753 : ! If the model_number is greater than 0 when star_load returns, then skip the call on
754 : ! star_alloc_extras because the arrays will have been automatically allocated and restored as part of
755 : ! the restart process. Call star_extra_arrays to get pointers to the arrays which will
756 : ! have the same content as when the snapshot was made.
757 : ! the routine star_finish_step will save the contents of the extra arrays along with
758 : ! the rest of the information for a restart.
759 : ! the routine star_load will restore the contents of the arrays when there is a restart.
760 : ! see star/test/src/rlo_exp.f for an example that uses this scheme.
761 0 : subroutine star_alloc_extras(id, len_extra_iwork, len_extra_work, ierr)
762 0 : use alloc, only: alloc_extras
763 : integer, intent(in) :: id
764 : integer, intent(in) :: len_extra_iwork, len_extra_work
765 : integer, intent(out) :: ierr
766 0 : call alloc_extras(id, len_extra_iwork, len_extra_work, ierr)
767 0 : end subroutine star_alloc_extras
768 :
769 :
770 : ! if for some reason, you're no longer interested in having extra arrays, you can call this.
771 : ! it is called automatically when you call free_star, so for normal use, you don't need to
772 : ! worry about deallocating extra arrays when you are finished with a star.
773 1 : subroutine star_dealloc_extras(id)
774 0 : use alloc, only: dealloc_extras
775 : integer, intent(in) :: id
776 : type (star_info), pointer :: s
777 : integer :: ierr
778 1 : call star_ptr(id,s,ierr)
779 1 : if (ierr /= 0) return
780 1 : call dealloc_extras(s)
781 1 : end subroutine star_dealloc_extras
782 :
783 :
784 0 : subroutine star_set_age(id, age, ierr)
785 1 : use evolve, only: set_age
786 : integer, intent(in) :: id
787 : real(dp), intent(in) :: age ! in years
788 : integer, intent(out) :: ierr
789 0 : call set_age(id, age, ierr)
790 0 : end subroutine star_set_age
791 :
792 :
793 : ! this routine is for changing use of Rayleigh-Taylor instabilities.
794 : ! simply changes variables; doesn't reconverge the model.
795 0 : subroutine star_set_RTI_flag(id, RTI_flag, ierr)
796 0 : use set_flags, only: set_RTI_flag
797 : integer, intent(in) :: id
798 : logical, intent(in) :: RTI_flag
799 : integer, intent(out) :: ierr
800 0 : call set_RTI_flag(id, RTI_flag, ierr)
801 0 : end subroutine star_set_RTI_flag
802 :
803 0 : subroutine star_set_w_div_wc_flag(id, w_div_wc_flag, ierr)
804 0 : use set_flags, only: set_w_div_wc_flag
805 : integer, intent(in) :: id
806 : logical, intent(in) :: w_div_wc_flag
807 : integer, intent(out) :: ierr
808 0 : write(*,*) "setting w_div_wc flag", w_div_wc_flag
809 0 : call set_w_div_wc_flag(id, w_div_wc_flag, ierr)
810 0 : end subroutine star_set_w_div_wc_flag
811 :
812 0 : subroutine star_set_j_rot_flag(id, j_rot_flag, ierr)
813 0 : use set_flags, only: set_j_rot_flag
814 : integer, intent(in) :: id
815 : logical, intent(in) :: j_rot_flag
816 : integer, intent(out) :: ierr
817 0 : write(*,*) "setting j_rot flag", j_rot_flag
818 0 : call set_j_rot_flag(id, j_rot_flag, ierr)
819 0 : end subroutine star_set_j_rot_flag
820 :
821 :
822 0 : subroutine star_set_RSP2_flag(id, et_flag, ierr)
823 0 : use set_flags, only: set_RSP2_flag
824 : integer, intent(in) :: id
825 : logical, intent(in) :: et_flag
826 : integer, intent(out) :: ierr
827 : type (star_info), pointer :: s
828 0 : call star_ptr(id, s, ierr)
829 0 : if (ierr /= 0) return
830 0 : call set_RSP2_flag(id, et_flag, ierr)
831 0 : end subroutine star_set_RSP2_flag
832 :
833 :
834 0 : subroutine star_set_RSP_flag(id, RSP_flag, ierr)
835 0 : use set_flags, only: set_RSP_flag
836 : integer, intent(in) :: id
837 : logical, intent(in) :: RSP_flag
838 : integer, intent(out) :: ierr
839 0 : call set_RSP_flag(id, RSP_flag, ierr)
840 0 : end subroutine star_set_RSP_flag
841 :
842 :
843 0 : subroutine star_set_D_omega_flag(id, D_omega_flag, ierr)
844 0 : use set_flags, only: set_D_omega_flag
845 : integer, intent(in) :: id
846 : logical, intent(in) :: D_omega_flag
847 : integer, intent(out) :: ierr
848 0 : call set_D_omega_flag(id, D_omega_flag, ierr)
849 0 : end subroutine star_set_D_omega_flag
850 :
851 :
852 0 : subroutine star_set_am_nu_rot_flag(id, am_nu_rot_flag, ierr)
853 0 : use set_flags, only: set_am_nu_rot_flag
854 : integer, intent(in) :: id
855 : logical, intent(in) :: am_nu_rot_flag
856 : integer, intent(out) :: ierr
857 0 : call set_am_nu_rot_flag(id, am_nu_rot_flag, ierr)
858 0 : end subroutine star_set_am_nu_rot_flag
859 :
860 :
861 : ! this routine is for adding or removing velocity variables.
862 : ! simply adds or removes; doesn't reconverge the model.
863 0 : subroutine star_set_v_flag(id, v_flag, ierr)
864 0 : use set_flags, only: set_v_flag
865 : integer, intent(in) :: id
866 : logical, intent(in) :: v_flag
867 : integer, intent(out) :: ierr
868 0 : call set_v_flag(id, v_flag, ierr)
869 0 : end subroutine star_set_v_flag
870 :
871 :
872 : ! this routine is for adding or removing velocity variables.
873 : ! simply adds or removes; doesn't reconverge the model.
874 0 : subroutine star_set_u_flag(id, u_flag, ierr)
875 0 : use set_flags, only: set_u_flag
876 : integer, intent(in) :: id
877 : logical, intent(in) :: u_flag
878 : integer, intent(out) :: ierr
879 0 : call set_u_flag(id, u_flag, ierr)
880 0 : end subroutine star_set_u_flag
881 :
882 :
883 : ! this routine is for adding or removing rotation variables.
884 : ! simply adds or removes; doesn't reconverge the model.
885 0 : subroutine star_set_rotation_flag(id, rotation_flag, ierr)
886 0 : use set_flags, only: set_rotation_flag
887 : use hydro_rotation, only: set_rotation_info
888 : integer, intent(in) :: id
889 : logical, intent(in) :: rotation_flag
890 : integer, intent(out) :: ierr
891 : logical :: previous_rotation_flag
892 : type (star_info), pointer :: s
893 0 : call star_ptr(id, s, ierr)
894 0 : if (ierr /= 0) then
895 0 : write(*,*) "Failed in star_ptr at star_set_rotation_flag"
896 : return
897 : end if
898 0 : previous_rotation_flag = s% rotation_flag
899 :
900 0 : call set_rotation_flag(id, rotation_flag, ierr)
901 :
902 0 : if (rotation_flag .and. .not. previous_rotation_flag) then
903 0 : call set_rotation_info(s, .false., ierr)
904 : end if
905 0 : end subroutine star_set_rotation_flag
906 :
907 :
908 : ! you can change the nuclear net at the start or between steps
909 : ! added species are given initial abundances based on solar scaled by initial_z
910 :
911 0 : subroutine star_change_to_new_net( &
912 : id, adjust_abundances_for_new_isos, new_net_name, ierr)
913 0 : use adjust_xyz, only: change_net
914 : integer, intent(in) :: id
915 : logical, intent(in) :: adjust_abundances_for_new_isos
916 : character (len=*), intent(in) :: new_net_name
917 : integer, intent(out) :: ierr
918 : call change_net( &
919 0 : id, adjust_abundances_for_new_isos, new_net_name, ierr)
920 0 : end subroutine star_change_to_new_net
921 :
922 :
923 0 : subroutine star_change_to_new_small_net( &
924 : id, adjust_abundances_for_new_isos, new_small_net_name, ierr)
925 0 : use adjust_xyz, only: change_small_net
926 : integer, intent(in) :: id
927 : logical, intent(in) :: adjust_abundances_for_new_isos
928 : character (len=*), intent(in) :: new_small_net_name
929 : integer, intent(out) :: ierr
930 : call change_small_net( &
931 0 : id, adjust_abundances_for_new_isos, new_small_net_name, ierr)
932 0 : end subroutine star_change_to_new_small_net
933 :
934 :
935 : ! Heger-style adaptive network (Woosley, Heger, et al, ApJSS, 151:75-102, 2004)
936 0 : subroutine star_adjust_net(id, &
937 : min_x_for_keep, min_x_for_n, min_x_for_add, max_Z, max_N, max_A, ierr)
938 0 : use adjust_net, only: check_adjust_net
939 : integer, intent(in) :: id
940 : real(dp), intent(in) :: &
941 : min_x_for_keep, min_x_for_n, min_x_for_add, max_Z, max_N, max_A
942 : integer, intent(out) :: ierr
943 : type (star_info), pointer :: s
944 0 : call star_ptr(id, s, ierr)
945 0 : if (ierr /= 0) return
946 : call check_adjust_net(s, s% species, &
947 : min_x_for_keep, min_x_for_n, min_x_for_add, &
948 0 : max_Z, max_N, max_A, ierr)
949 0 : end subroutine star_adjust_net
950 :
951 :
952 0 : logical function is_included_in_net(id, species, ierr)
953 : integer, intent(in) :: id
954 : integer, intent(in) :: species ! a chem_id such as ihe3. see chem_def.
955 : integer, intent(out) :: ierr
956 : type (star_info), pointer :: s
957 0 : call star_ptr(id, s, ierr)
958 0 : if (ierr /= 0) then
959 0 : is_included_in_net = .false.
960 : return
961 : end if
962 0 : is_included_in_net = (s% net_iso(species) /= 0)
963 0 : end function is_included_in_net
964 :
965 :
966 : ! here are some routines for doing special adjustments to the star's composition
967 :
968 :
969 : ! set uniform composition with one of the standard metal z fractions from chem_def
970 0 : subroutine star_set_standard_composition(id, h1, h2, he3, he4, &
971 : which_zfracs, dump_missing_metals_into_heaviest, ierr)
972 : use adjust_xyz, only: set_standard_composition
973 : integer, intent(in) :: id
974 : real(dp), intent(in) :: h1, h2, he3, he4 ! mass fractions
975 : integer, intent(in) :: which_zfracs ! defined in chem_def. e.g., GS98_zfracs
976 : logical, intent(in) :: dump_missing_metals_into_heaviest
977 : integer, intent(out) :: ierr
978 : type (star_info), pointer :: s
979 0 : call star_ptr(id, s, ierr)
980 0 : if (ierr /= 0) return
981 : call set_standard_composition(s, s% species, h1, h2, he3, he4, &
982 0 : which_zfracs, dump_missing_metals_into_heaviest, ierr)
983 0 : end subroutine star_set_standard_composition
984 :
985 :
986 0 : subroutine star_uniform_xa_from_file(id, file_for_uniform_xa, ierr)
987 0 : use adjust_xyz, only: set_uniform_xa_from_file
988 : integer, intent(in) :: id
989 : character (len=*), intent(in) :: file_for_uniform_xa
990 : integer, intent(out) :: ierr
991 0 : call set_uniform_xa_from_file(id, file_for_uniform_xa, ierr)
992 0 : end subroutine star_uniform_xa_from_file
993 :
994 :
995 0 : subroutine star_set_uniform_composition(id, species, xa, ierr)
996 0 : use adjust_xyz, only: set_uniform_composition
997 : integer, intent(in) :: id
998 : integer, intent(in) :: species
999 : real(dp), intent(in) :: xa(species)
1000 : integer, intent(out) :: ierr
1001 0 : call set_uniform_composition(id, species, xa, ierr)
1002 0 : end subroutine star_set_uniform_composition
1003 :
1004 :
1005 0 : subroutine star_set_composition(id, species, xa, ierr)
1006 0 : use adjust_xyz, only: set_composition
1007 : integer, intent(in) :: id
1008 : integer, intent(in) :: species
1009 : real(dp), intent(in) :: xa(species) ! the replacement mass fractions
1010 : integer, intent(out) :: ierr
1011 : type (star_info), pointer :: s
1012 0 : call star_ptr(id, s, ierr)
1013 0 : if (ierr /= 0) return
1014 0 : call set_composition(id, 1, s% nz, species, xa, ierr)
1015 0 : end subroutine star_set_composition
1016 :
1017 :
1018 0 : subroutine set_composition_in_section(id, nzlo, nzhi, species, xa, ierr)
1019 0 : use adjust_xyz, only: set_composition
1020 : integer, intent(in) :: id
1021 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1022 : integer, intent(in) :: species
1023 : real(dp), intent(in) :: xa(species) ! cells from nzlo to nzhi get this composition.
1024 : integer, intent(out) :: ierr
1025 0 : call set_composition(id, nzlo, nzhi, species, xa, ierr)
1026 0 : end subroutine set_composition_in_section
1027 :
1028 :
1029 0 : subroutine change_to_xa_for_accretion(id, nzlo, nzhi, ierr)
1030 0 : use adjust_xyz, only: do_change_to_xa_for_accretion
1031 : integer, intent(in) :: id
1032 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1033 : integer, intent(out) :: ierr
1034 0 : call do_change_to_xa_for_accretion(id, nzlo, nzhi, ierr)
1035 0 : end subroutine change_to_xa_for_accretion
1036 :
1037 :
1038 0 : subroutine star_set_abundance_ratio(id, i1, i2, ratio, ierr)
1039 0 : use adjust_xyz, only: set_abundance_ratio
1040 : integer, intent(in) :: id
1041 : integer, intent(in) :: i1, i2 ! chem id's such as ih1 or ihe4 from chem_def
1042 : real(dp), intent(in) :: ratio ! change abundances of i1 and i2 s.t. x(i1)/x(i2)=ratio
1043 : integer, intent(out) :: ierr
1044 : type (star_info), pointer :: s
1045 0 : call star_ptr(id, s, ierr)
1046 0 : if (ierr /= 0) return
1047 0 : call set_abundance_ratio(id, i1, i2, ratio, 1, s% nz, ierr)
1048 0 : end subroutine star_set_abundance_ratio
1049 :
1050 :
1051 0 : subroutine set_abundance_ratio_in_section(id, i1, i2, ratio, nzlo, nzhi, ierr)
1052 0 : use adjust_xyz, only: set_abundance_ratio
1053 : integer, intent(in) :: id
1054 : integer, intent(in) :: i1, i2 ! chem id's such as ih1 or ihe4 from chem_def
1055 : real(dp), intent(in) :: ratio ! change abundances of i1 and i2 s.t. x(i1)/x(i2)=ratio
1056 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1057 : integer, intent(out) :: ierr
1058 0 : call set_abundance_ratio(id, i1, i2, ratio, nzlo, nzhi, ierr)
1059 0 : end subroutine set_abundance_ratio_in_section
1060 :
1061 :
1062 0 : subroutine star_zero_alpha_RTI(id, ierr)
1063 0 : use star_utils, only: set_zero_alpha_RTI
1064 : integer, intent(in) :: id
1065 : integer, intent(out) :: ierr
1066 0 : call set_zero_alpha_RTI(id, ierr)
1067 0 : end subroutine star_zero_alpha_RTI
1068 :
1069 :
1070 0 : subroutine star_set_y(id, y, ierr)
1071 : ! changes abundances of h1 and he4 only
1072 : ! adjust ratio of h1 to he4 to be (1-y-z)/y at each point
1073 0 : use adjust_xyz, only: set_y
1074 : integer, intent(in) :: id
1075 : real(dp), intent(in) :: y ! new value for average he4 mass fraction
1076 : integer, intent(out) :: ierr
1077 : type (star_info), pointer :: s
1078 0 : call star_ptr(id, s, ierr)
1079 0 : if (ierr /= 0) return
1080 0 : call set_y(s, y, 1, s% nz, ierr)
1081 0 : end subroutine star_set_y
1082 :
1083 :
1084 0 : subroutine set_y_in_section(id, y, nzlo, nzhi, ierr)
1085 : ! change abundances of h1 and he4
1086 0 : use adjust_xyz, only: set_y
1087 : integer, intent(in) :: id
1088 : real(dp), intent(in) :: y ! new value for average he4 mass fraction
1089 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1090 : integer, intent(out) :: ierr
1091 : type (star_info), pointer :: s
1092 0 : call star_ptr(id, s, ierr)
1093 0 : if (ierr /= 0) return
1094 0 : call set_y(s, y, nzlo, nzhi, ierr)
1095 0 : end subroutine set_y_in_section
1096 :
1097 :
1098 0 : subroutine star_set_z(id, new_z, ierr)
1099 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1100 : ! to make large changes in z, you'll need to spread it out over a number of steps
1101 : ! in order to let the model adjust to the changes a small amount at a time.
1102 0 : use adjust_xyz, only: set_z
1103 : integer, intent(in) :: id
1104 : real(dp), intent(in) :: new_z
1105 : integer, intent(out) :: ierr
1106 : type (star_info), pointer :: s
1107 0 : call star_ptr(id, s, ierr)
1108 0 : if (ierr /= 0) return
1109 0 : call set_z(s, new_z, 1, s% nz, ierr)
1110 0 : end subroutine star_set_z
1111 :
1112 :
1113 0 : subroutine set_z_in_section(id, new_z, nzlo, nzhi, ierr)
1114 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1115 : ! to make large changes in z, you'll need to spread it out over a number of steps
1116 : ! in order to let the model adjust to the changes a small amount at a time.
1117 : ! BTW: the set_z routine considers everything to be a "metal" except H1 and He4.
1118 0 : use adjust_xyz, only: set_z
1119 : integer, intent(in) :: id
1120 : real(dp), intent(in) :: new_z
1121 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1122 : integer, intent(out) :: ierr
1123 : type (star_info), pointer :: s
1124 0 : call star_ptr(id, s, ierr)
1125 0 : if (ierr /= 0) return
1126 0 : call set_z(s, new_z, nzlo, nzhi, ierr)
1127 0 : end subroutine set_z_in_section
1128 :
1129 :
1130 0 : subroutine star_replace_element(id, chem1, chem2, ierr)
1131 : ! replaces chem1 by chem2.
1132 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1133 : integer, intent(in) :: id
1134 : integer, intent(in) :: chem1, chem2 ! values are chem_id's such as ihe4. see chem_def.
1135 : integer, intent(out) :: ierr
1136 : type (star_info), pointer :: s
1137 0 : call star_ptr(id, s, ierr)
1138 0 : if (ierr /= 0) return
1139 0 : call replace_element_in_section(id, chem1, chem2, 1, s% nz, ierr)
1140 0 : end subroutine star_replace_element
1141 :
1142 :
1143 0 : subroutine replace_element_in_section(id, chem1, chem2, nzlo, nzhi, ierr)
1144 : ! replaces chem1 by chem2.
1145 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1146 : use adjust_xyz, only: do_replace
1147 : integer, intent(in) :: id
1148 : integer, intent(in) :: chem1, chem2 ! values are chem_id's such as ihe4. see chem_def.
1149 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1150 : integer, intent(out) :: ierr
1151 : type (star_info), pointer :: s
1152 0 : call star_ptr(id, s, ierr)
1153 0 : if (ierr /= 0) return
1154 0 : call do_replace(s, chem1, chem2, nzlo, nzhi, ierr)
1155 0 : end subroutine replace_element_in_section
1156 :
1157 :
1158 0 : subroutine star_set_abundance(id, chem_id, new_frac, ierr)
1159 : ! set mass fraction of species to new_frac uniformly in cells nzlo to nzhi
1160 : !
1161 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1162 : integer, intent(in) :: id
1163 : integer, intent(in) :: chem_id ! a chem_id such as ihe4. see chem_def.
1164 : real(dp), intent(in) :: new_frac
1165 : integer, intent(out) :: ierr
1166 : type (star_info), pointer :: s
1167 0 : call star_ptr(id, s, ierr)
1168 0 : if (ierr /= 0) return
1169 0 : call set_abundance_in_section(id, chem_id, new_frac, 1, s% nz, ierr)
1170 0 : end subroutine star_set_abundance
1171 :
1172 :
1173 0 : subroutine set_abundance_in_section(id, chem_id, new_frac, nzlo, nzhi, ierr)
1174 : ! set mass fraction of species to new_frac uniformly in cells nzlo to nzhi
1175 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1176 : use adjust_xyz, only: do_set_abundance
1177 : integer, intent(in) :: id
1178 : integer, intent(in) :: chem_id ! a chem_id such as ihe4. see chem_def.
1179 : real(dp), intent(in) :: new_frac
1180 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1181 : integer, intent(out) :: ierr
1182 : type (star_info), pointer :: s
1183 0 : call star_ptr(id, s, ierr)
1184 0 : if (ierr /= 0) return
1185 0 : call do_set_abundance(s, chem_id, new_frac, nzlo, nzhi, ierr)
1186 0 : end subroutine set_abundance_in_section
1187 :
1188 :
1189 0 : subroutine uniform_mix_section(id, nzlo, nzhi, ierr)
1190 : ! uniformly mix abundances in cells nzlo to nzhi
1191 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1192 0 : use adjust_xyz, only: do_uniform_mix_section
1193 : integer, intent(in) :: id
1194 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1195 : integer, intent(out) :: ierr
1196 : type (star_info), pointer :: s
1197 0 : write(*,*) 'uniform_mix_section'
1198 0 : call star_ptr(id, s, ierr)
1199 0 : if (ierr /= 0) return
1200 0 : call do_uniform_mix_section(s, s% species, nzlo, nzhi, ierr)
1201 0 : end subroutine uniform_mix_section
1202 :
1203 :
1204 0 : subroutine uniform_mix_envelope_down_to_T(id, T, ierr)
1205 : ! uniformly mix abundances in cells from surface down to given temperature
1206 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1207 0 : use adjust_xyz, only: do_uniform_mix_envelope_down_to_T
1208 : integer, intent(in) :: id
1209 : real(dp), intent(in) :: T
1210 : integer, intent(out) :: ierr
1211 : type (star_info), pointer :: s
1212 0 : write(*,*) 'uniform_mix_envelope_down_to_T'
1213 0 : call star_ptr(id, s, ierr)
1214 0 : if (ierr /= 0) return
1215 0 : call do_uniform_mix_envelope_down_to_T(s, T, ierr)
1216 0 : end subroutine uniform_mix_envelope_down_to_T
1217 :
1218 :
1219 : ! access to the value of the next timestep
1220 :
1221 0 : subroutine get_dt_next(id, dt, ierr)
1222 0 : use star_private_def
1223 : integer, intent(in) :: id
1224 : real(dp) , intent(out) :: dt
1225 : integer, intent(out) :: ierr
1226 : type (star_info), pointer :: s
1227 0 : call star_ptr(id, s, ierr)
1228 0 : if (ierr /= 0) then
1229 0 : dt = -1
1230 : return
1231 : end if
1232 0 : dt = s% dt_next
1233 0 : end subroutine get_dt_next
1234 :
1235 :
1236 0 : subroutine set_dt_next(id, dt, ierr)
1237 0 : use star_private_def
1238 : integer, intent(in) :: id
1239 : real(dp), intent(in) :: dt
1240 : integer, intent(out) :: ierr
1241 : type (star_info), pointer :: s
1242 0 : call star_ptr(id, s, ierr)
1243 0 : if (ierr /= 0) return
1244 0 : s% dt_next = dt
1245 0 : end subroutine set_dt_next
1246 :
1247 :
1248 : ! relaxation routines (for "pseudo-evolution" of the model)
1249 :
1250 0 : subroutine star_relax_mass(id, new_mass, lg_max_abs_mdot, ierr) ! also resets initial_mass
1251 : ! acts like accretion or wind to change star mass
1252 0 : use relax, only: do_relax_mass
1253 : integer, intent(in) :: id
1254 : real(dp), intent(in) :: new_mass ! in Msun units
1255 : real(dp), intent(in) :: lg_max_abs_mdot ! in log10(Msun/year)
1256 : ! e.g., -8.0 for mdot of -10^-8 Msun/year
1257 : integer, intent(out) :: ierr
1258 0 : call do_relax_mass(id, new_mass, lg_max_abs_mdot, ierr)
1259 0 : end subroutine star_relax_mass
1260 :
1261 :
1262 0 : subroutine star_relax_mass_to_remove_H_env( &
1263 : id, extra_mass, lg_max_abs_mdot, ierr) ! also resets initial_mass
1264 0 : use relax, only: do_relax_mass
1265 : use report, only: get_mass_info
1266 : integer, intent(in) :: id
1267 : real(dp), intent(in) :: extra_mass
1268 : real(dp), intent(in) :: lg_max_abs_mdot ! in log10(Msun/year)
1269 : ! e.g., -8.0 for mdot of -10^-8 Msun/year
1270 : integer, intent(out) :: ierr
1271 : type (star_info), pointer :: s
1272 : ierr = 0
1273 0 : call star_ptr(id, s, ierr)
1274 0 : if (ierr /= 0) return
1275 0 : call get_mass_info(s, s% dm, ierr)
1276 0 : if (ierr /= 0) return
1277 0 : call do_relax_mass(id, s% he_core_mass + extra_mass, lg_max_abs_mdot, ierr)
1278 0 : end subroutine star_relax_mass_to_remove_H_env
1279 :
1280 :
1281 0 : subroutine star_relax_mass_scale( &
1282 : id, new_mass, dlgm_per_step, change_mass_years_for_dt, ierr) ! also resets initial_mass
1283 : ! rescales star mass without changing composition as function of m/mstar
1284 0 : use relax, only: do_relax_mass_scale
1285 : integer, intent(in) :: id
1286 : real(dp), intent(in) :: new_mass ! in Msun units
1287 : real(dp), intent(in) :: dlgm_per_step, change_mass_years_for_dt
1288 : integer, intent(out) :: ierr
1289 : call do_relax_mass_scale( &
1290 0 : id, new_mass, dlgm_per_step, change_mass_years_for_dt, ierr)
1291 0 : end subroutine star_relax_mass_scale
1292 :
1293 :
1294 0 : subroutine star_relax_core( &
1295 : id, new_core_mass, dlg_core_mass_per_step, &
1296 : relax_core_years_for_dt, core_avg_rho, core_avg_eps, ierr)
1297 0 : use relax, only: do_relax_core
1298 : integer, intent(in) :: id
1299 : real(dp), intent(in) :: new_core_mass ! in Msun units
1300 : real(dp), intent(in) :: dlg_core_mass_per_step, relax_core_years_for_dt
1301 : real(dp), intent(in) :: core_avg_rho, core_avg_eps
1302 : ! adjust R_center according to core_avg_rho (g cm^-3)
1303 : ! adjust L_center according to core_avg_eps (erg g^-1 s^-1)
1304 : integer, intent(out) :: ierr
1305 : call do_relax_core( &
1306 : id, new_core_mass, dlg_core_mass_per_step, &
1307 0 : relax_core_years_for_dt, core_avg_rho, core_avg_eps, ierr)
1308 0 : end subroutine star_relax_core
1309 :
1310 :
1311 0 : subroutine star_relax_M_center( &
1312 : id, new_mass, dlgm_per_step, relax_M_center_dt, ierr)
1313 0 : use relax, only: do_relax_M_center
1314 : integer, intent(in) :: id
1315 : real(dp), intent(in) :: new_mass ! in Msun units
1316 : real(dp), intent(in) :: dlgm_per_step, relax_M_center_dt
1317 : integer, intent(out) :: ierr
1318 : call do_relax_M_center( &
1319 0 : id, new_mass, dlgm_per_step, relax_M_center_dt, ierr)
1320 0 : end subroutine star_relax_M_center
1321 :
1322 :
1323 0 : subroutine star_relax_R_center( &
1324 : id, new_R_center, dlgR_per_step, relax_R_center_dt, ierr)
1325 0 : use relax, only: do_relax_R_center
1326 : integer, intent(in) :: id
1327 : real(dp), intent(in) :: new_R_center ! in cm
1328 : real(dp), intent(in) :: dlgR_per_step, relax_R_center_dt
1329 : integer, intent(out) :: ierr
1330 : call do_relax_R_center( &
1331 0 : id, new_R_center, dlgR_per_step, relax_R_center_dt, ierr)
1332 0 : end subroutine star_relax_R_center
1333 :
1334 :
1335 0 : subroutine star_relax_v_center( &
1336 : id, new_v_center, dv_per_step, relax_v_center_dt, ierr)
1337 0 : use relax, only: do_relax_v_center
1338 : integer, intent(in) :: id
1339 : real(dp), intent(in) :: new_v_center ! in cm/s
1340 : real(dp), intent(in) :: dv_per_step, relax_v_center_dt
1341 : integer, intent(out) :: ierr
1342 : call do_relax_v_center( &
1343 0 : id, new_v_center, dv_per_step, relax_v_center_dt, ierr)
1344 0 : end subroutine star_relax_v_center
1345 :
1346 :
1347 0 : subroutine star_relax_L_center( &
1348 : id, new_L_center, dlgL_per_step, relax_L_center_dt, ierr)
1349 0 : use relax, only: do_relax_L_center
1350 : integer, intent(in) :: id
1351 : real(dp), intent(in) :: new_L_center ! in ergs/second
1352 : real(dp), intent(in) :: dlgL_per_step, relax_L_center_dt
1353 : integer, intent(out) :: ierr
1354 : call do_relax_L_center( &
1355 0 : id, new_L_center, dlgL_per_step, relax_L_center_dt, ierr)
1356 0 : end subroutine star_relax_L_center
1357 :
1358 :
1359 0 : subroutine star_relax_dxdt_nuc_factor(id, new_value, per_step_multiplier, ierr)
1360 0 : use relax, only: do_relax_dxdt_nuc_factor
1361 : integer, intent(in) :: id
1362 : real(dp), intent(in) :: new_value
1363 : real(dp), intent(in) :: per_step_multiplier
1364 : integer, intent(out) :: ierr
1365 0 : call do_relax_dxdt_nuc_factor(id, new_value, per_step_multiplier, ierr)
1366 0 : end subroutine star_relax_dxdt_nuc_factor
1367 :
1368 :
1369 0 : subroutine star_relax_eps_nuc_factor(id, new_value, per_step_multiplier, ierr)
1370 0 : use relax, only: do_relax_eps_nuc_factor
1371 : integer, intent(in) :: id
1372 : real(dp), intent(in) :: new_value
1373 : real(dp), intent(in) :: per_step_multiplier
1374 : integer, intent(out) :: ierr
1375 0 : call do_relax_eps_nuc_factor(id, new_value, per_step_multiplier, ierr)
1376 0 : end subroutine star_relax_eps_nuc_factor
1377 :
1378 :
1379 0 : subroutine star_relax_opacity_max(id, new_value, per_step_multiplier, ierr)
1380 0 : use relax, only: do_relax_opacity_max
1381 : integer, intent(in) :: id
1382 : real(dp), intent(in) :: new_value
1383 : real(dp), intent(in) :: per_step_multiplier
1384 : integer, intent(out) :: ierr
1385 0 : call do_relax_opacity_max(id, new_value, per_step_multiplier, ierr)
1386 0 : end subroutine star_relax_opacity_max
1387 :
1388 :
1389 0 : subroutine star_relax_max_surf_dq(id, new_value, per_step_multiplier, ierr)
1390 0 : use relax, only: do_relax_max_surf_dq
1391 : integer, intent(in) :: id
1392 : real(dp), intent(in) :: new_value
1393 : real(dp), intent(in) :: per_step_multiplier
1394 : integer, intent(out) :: ierr
1395 0 : call do_relax_max_surf_dq(id, new_value, per_step_multiplier, ierr)
1396 0 : end subroutine star_relax_max_surf_dq
1397 :
1398 :
1399 0 : subroutine star_relax_composition( &
1400 0 : id, num_steps_to_use, num_pts, species, xa, xq, ierr)
1401 : ! with normal composition changes turned off,
1402 : ! incrementally revise composition to get requested profile
1403 0 : use relax, only: do_relax_composition
1404 : integer, intent(in) :: id
1405 : integer, intent(in) :: num_steps_to_use ! use this many steps to do conversion
1406 : integer, intent(in) :: num_pts
1407 : ! length of composition vector; need not equal nz for current model (will interpolate)
1408 : integer, intent(in) :: species
1409 : ! must = number of species for current model
1410 : real(dp), intent(in) :: xa(:,:) ! (species, num_pts) ! target composition profile
1411 : real(dp), intent(in) :: xq(:) ! (num_pts)
1412 : ! xq(i) = fraction of xmstar exterior to the point i
1413 : ! where xmstar = mstar - M_center
1414 : integer, intent(out) :: ierr
1415 0 : call do_relax_composition(id, num_steps_to_use, num_pts, species, xa, xq, ierr)
1416 0 : end subroutine star_relax_composition
1417 :
1418 0 : subroutine star_relax_angular_momentum( &
1419 0 : id, max_steps_to_use, num_pts, angular_momentum, xq, ierr)
1420 : ! with normal composition changes turned off,
1421 : ! add extra heating term to get requested entropy profile
1422 0 : use relax, only: do_relax_angular_momentum
1423 : integer, intent(in) :: id
1424 : integer, intent(in) :: max_steps_to_use ! use this many steps to do conversion
1425 : integer, intent(in) :: num_pts
1426 : ! length of angular momentum vector; need not equal nz for current model (will interpolate)
1427 : real(dp), intent(in) :: angular_momentum(:) ! (num_pts) ! target am profile
1428 : real(dp), intent(in) :: xq(:) ! (num_pts)
1429 : ! xq(i) = fraction of xmstar exterior to the point i
1430 : ! where xmstar = mstar - M_center
1431 : integer, intent(out) :: ierr
1432 0 : call do_relax_angular_momentum(id, max_steps_to_use, num_pts, angular_momentum, xq, ierr)
1433 0 : end subroutine star_relax_angular_momentum
1434 :
1435 0 : subroutine star_relax_entropy( &
1436 0 : id, max_steps_to_use, num_pts, entropy, xq, ierr)
1437 : ! with normal composition changes turned off,
1438 : ! add extra heating term to get requested entropy profile
1439 0 : use relax, only: do_relax_entropy
1440 : integer, intent(in) :: id
1441 : integer, intent(in) :: max_steps_to_use ! use this many steps to do conversion
1442 : integer, intent(in) :: num_pts
1443 : ! length of entropy vector; need not equal nz for current model (will interpolate)
1444 : real(dp), intent(in) :: entropy(:) ! (num_pts) ! target entropy profile
1445 : real(dp), intent(in) :: xq(:) ! (num_pts)
1446 : ! xq(i) = fraction of xmstar exterior to the point i
1447 : ! where xmstar = mstar - M_center
1448 : integer, intent(out) :: ierr
1449 0 : call do_relax_entropy(id, max_steps_to_use, num_pts, entropy, xq, ierr)
1450 0 : end subroutine star_relax_entropy
1451 :
1452 0 : subroutine star_relax_to_xaccrete(id, num_steps_to_use, ierr)
1453 : ! with normal composition changes turned off,
1454 : ! incrementally revise composition to get uniform match to current accretion specs
1455 0 : use relax, only: do_relax_to_xaccrete
1456 : integer, intent(in) :: id
1457 : integer, intent(in) :: num_steps_to_use ! use this many steps to do conversion
1458 : integer, intent(out) :: ierr
1459 0 : call do_relax_to_xaccrete(id, num_steps_to_use, ierr)
1460 0 : end subroutine star_relax_to_xaccrete
1461 :
1462 :
1463 0 : subroutine star_relax_Y(id, new_Y, dY, minq, maxq, ierr) ! also resets initial_y
1464 0 : use relax, only: do_relax_Y
1465 : integer, intent(in) :: id
1466 : real(dp), intent(in) :: new_Y
1467 : real(dp), intent(in) :: dY ! change Y by this amount per step
1468 : real(dp), intent(in) :: minq, maxq ! change in this q range
1469 : integer, intent(out) :: ierr
1470 0 : call do_relax_Y(id, new_Y, dY, minq, maxq, ierr)
1471 0 : end subroutine star_relax_Y
1472 :
1473 :
1474 0 : subroutine star_relax_Z(id, new_z, dlnz, minq, maxq, ierr) ! also resets initial_z
1475 0 : use relax, only: do_relax_Z
1476 : integer, intent(in) :: id
1477 : real(dp), intent(in) :: new_z
1478 : real(dp), intent(in) :: dlnz ! change lnz by this amount per step
1479 : real(dp), intent(in) :: minq, maxq ! change in this q range
1480 : integer, intent(out) :: ierr
1481 0 : call do_relax_Z(id, new_z, dlnz, minq, maxq, ierr)
1482 0 : end subroutine star_relax_Z
1483 :
1484 :
1485 : ! the optical depth of the outermost cell is tau_factor*tau_photosphere
1486 : ! for normal hydrostatic stellar evolution, tau_factor = 1
1487 : ! but in general, the limits are 0 < tau_factor <= 1,
1488 : ! so by making tau_factor << 1, you can include the atmosphere in the model.
1489 0 : subroutine star_relax_tau_factor(id, new_tau_factor, dlogtau_factor, ierr)
1490 0 : use relax, only: do_relax_tau_factor
1491 : integer, intent(in) :: id
1492 : real(dp), intent(in) :: new_tau_factor
1493 : real(dp), intent(in) :: dlogtau_factor
1494 : ! change log10(tau_factor) by at most this amount per step
1495 : integer, intent(out) :: ierr
1496 0 : call do_relax_tau_factor(id, new_tau_factor, dlogtau_factor, ierr)
1497 0 : end subroutine star_relax_tau_factor
1498 :
1499 :
1500 : ! for normal stellar evolution, opacity_factor = 1
1501 : ! but for post-breakout CCSN, the expansion effects can be approximated by increasing kap.
1502 0 : subroutine star_relax_opacity_factor(id, new_opacity_factor, dopacity_factor, ierr)
1503 0 : use relax, only: do_relax_opacity_factor
1504 : integer, intent(in) :: id
1505 : real(dp), intent(in) :: new_opacity_factor
1506 : real(dp), intent(in) :: dopacity_factor
1507 : ! change opacity_factor by at most this amount per step
1508 : integer, intent(out) :: ierr
1509 0 : call do_relax_opacity_factor(id, new_opacity_factor, dopacity_factor, ierr)
1510 0 : end subroutine star_relax_opacity_factor
1511 :
1512 :
1513 0 : subroutine star_relax_Tsurf_factor(id, new_Tsurf_factor, dlogTsurf_factor, ierr)
1514 0 : use relax, only: do_relax_Tsurf_factor
1515 : integer, intent(in) :: id
1516 : real(dp), intent(in) :: new_Tsurf_factor
1517 : real(dp), intent(in) :: dlogTsurf_factor
1518 : ! change log10(Tsurf_factor) by at most this amount per step
1519 : integer, intent(out) :: ierr
1520 0 : call do_relax_Tsurf_factor(id, new_Tsurf_factor, dlogTsurf_factor, ierr)
1521 0 : end subroutine star_relax_Tsurf_factor
1522 :
1523 :
1524 : ! kind_of_relax = 0 => target = new_omega
1525 : ! kind_of_relax = 1 => target = new_omega_div_omega_crit
1526 : ! kind_of_relax = 2 => target = new_surface_rotation_v
1527 0 : subroutine star_relax_uniform_omega(id, &
1528 : kind_of_relax, target_value, num_steps_to_relax_rotation, &
1529 : relax_omega_max_yrs_dt, ierr)
1530 0 : use relax, only: do_relax_uniform_omega
1531 : integer, intent(in) :: id, kind_of_relax, num_steps_to_relax_rotation
1532 : real(dp), intent(in) :: target_value,relax_omega_max_yrs_dt
1533 : integer, intent(out) :: ierr
1534 : call do_relax_uniform_omega(id, &
1535 : kind_of_relax, target_value, num_steps_to_relax_rotation, &
1536 0 : relax_omega_max_yrs_dt, ierr)
1537 0 : end subroutine star_relax_uniform_omega
1538 :
1539 :
1540 0 : subroutine star_relax_irradiation(id, &
1541 : min_steps, new_irrad_flux, new_irrad_col_depth, &
1542 : relax_irradiation_max_yrs_dt, ierr)
1543 0 : use relax, only: do_relax_irradiation
1544 : integer, intent(in) :: id, min_steps
1545 : real(dp), intent(in) :: &
1546 : new_irrad_flux, new_irrad_col_depth, relax_irradiation_max_yrs_dt
1547 : integer, intent(out) :: ierr
1548 : call do_relax_irradiation(id, &
1549 0 : min_steps, new_irrad_flux, new_irrad_col_depth, relax_irradiation_max_yrs_dt, ierr)
1550 0 : end subroutine star_relax_irradiation
1551 :
1552 :
1553 0 : subroutine star_relax_mass_change( &
1554 : id, min_steps, initial_mass_change, final_mass_change, relax_mass_change_max_yrs_dt, ierr)
1555 0 : use relax, only: do_relax_mass_change
1556 : integer, intent(in) :: id, min_steps
1557 : real(dp), intent(in) :: initial_mass_change, final_mass_change, relax_mass_change_max_yrs_dt
1558 : integer, intent(out) :: ierr
1559 : call do_relax_mass_change( &
1560 0 : id, min_steps, initial_mass_change, final_mass_change, relax_mass_change_max_yrs_dt, ierr)
1561 0 : end subroutine star_relax_mass_change
1562 :
1563 :
1564 0 : subroutine star_relax_num_steps(id, num_steps, max_timestep, ierr)
1565 0 : use relax, only: do_relax_num_steps
1566 : integer, intent(in) :: id, num_steps
1567 : real(dp), intent(in) :: max_timestep
1568 : integer, intent(out) :: ierr
1569 0 : call do_relax_num_steps(id, num_steps, max_timestep, ierr)
1570 0 : end subroutine star_relax_num_steps
1571 :
1572 :
1573 : ! evolve until star_check_limits returns terminate.
1574 0 : subroutine star_evolve_to_limit(id, restore_at_end, ierr)
1575 0 : use relax, only: do_relax_to_limit
1576 : integer, intent(in) :: id
1577 : logical, intent(in) :: restore_at_end
1578 : integer, intent(out) :: ierr
1579 0 : call do_relax_to_limit(id, restore_at_end, ierr)
1580 0 : end subroutine star_evolve_to_limit
1581 :
1582 :
1583 : ! evolve until check_model says to stop.
1584 : ! this is intended for use in special "relax to" operations.
1585 : ! for normal evolution, you will probably want to use the ./rn script.
1586 0 : subroutine star_evolve_to_check_point( &
1587 : id, before_evolve, adjust_model, check_model, finish_model, &
1588 : restore_at_end, lipar, ipar, lrpar, rpar, ierr)
1589 0 : use relax, only: do_internal_evolve
1590 : integer, intent(in) :: id, lipar, lrpar
1591 : logical, intent(in) :: restore_at_end
1592 : integer, intent(inout), pointer :: ipar(:) ! (lipar)
1593 : real(dp), intent(inout), pointer :: rpar(:) ! (lrpar)
1594 : interface
1595 : subroutine before_evolve(s, id, lipar, ipar, lrpar, rpar, ierr)
1596 : use const_def, only: dp
1597 : use star_def, only: star_info
1598 : implicit none
1599 : type (star_info), pointer :: s
1600 : integer, intent(in) :: id, lipar, lrpar
1601 : integer, intent(inout), pointer :: ipar(:) ! (lipar)
1602 : real(dp), intent(inout), pointer :: rpar(:) ! (lrpar)
1603 : integer, intent(out) :: ierr
1604 : end subroutine before_evolve
1605 : integer function adjust_model(s, id, lipar, ipar, lrpar, rpar)
1606 : ! returns either keep_going, redo, retry, or terminate.
1607 : ! for okay termination, set s% termination_code = t_relax_finished_okay
1608 : use const_def, only: dp
1609 : use star_def, only: star_info
1610 : implicit none
1611 : type (star_info), pointer :: s
1612 : integer, intent(in) :: id, lipar, lrpar
1613 : integer, intent(inout), pointer :: ipar(:) ! (lipar)
1614 : real(dp), intent(inout), pointer :: rpar(:) ! (lrpar)
1615 : end function adjust_model
1616 : integer function check_model(s, id, lipar, ipar, lrpar, rpar)
1617 : ! returns either keep_going, redo, retry, or terminate.
1618 : ! for okay termination, set s% termination_code = t_relax_finished_okay
1619 : use const_def, only: dp
1620 : use star_def, only: star_info
1621 : implicit none
1622 : type (star_info), pointer :: s
1623 : integer, intent(in) :: id, lipar, lrpar
1624 : integer, intent(inout), pointer :: ipar(:) ! (lipar)
1625 : real(dp), intent(inout), pointer :: rpar(:) ! (lrpar)
1626 : end function check_model
1627 : integer function finish_model(s)
1628 : use star_def, only:star_info
1629 : implicit none
1630 : type (star_info), pointer :: s
1631 : end function finish_model
1632 : end interface
1633 : integer, intent(out) :: ierr
1634 : call do_internal_evolve( &
1635 : id, before_evolve, adjust_model, check_model, finish_model, &
1636 0 : restore_at_end, lipar, ipar, lrpar, rpar, ierr)
1637 0 : end subroutine star_evolve_to_check_point
1638 :
1639 :
1640 : ! I use this sometimes for debugging.
1641 0 : subroutine star_special_test(id, ierr)
1642 : integer, intent(in) :: id
1643 : integer, intent(out) :: ierr
1644 : type (star_info), pointer :: s
1645 : ierr = 0
1646 0 : call star_ptr(id, s, ierr)
1647 0 : if (ierr /= 0) return
1648 0 : end subroutine star_special_test
1649 :
1650 :
1651 : ! rotation
1652 :
1653 : ! note: this applies to the current model only;
1654 : ! subsequent models may evolve away from solid body rotation.
1655 0 : subroutine star_set_uniform_omega(id, omega, ierr)
1656 : use hydro_rotation, only: set_uniform_omega
1657 : integer, intent(in) :: id
1658 : real(dp), intent(in) :: omega
1659 : integer, intent(out) :: ierr
1660 0 : call set_uniform_omega(id, omega, ierr)
1661 0 : end subroutine star_set_uniform_omega
1662 :
1663 :
1664 : ! a few miscellaneous extra routines for special jobs
1665 :
1666 :
1667 : ! call this if you want a description of the terminal log output
1668 0 : subroutine show_log_description(id, ierr)
1669 0 : use do_one_utils, only: do_show_log_description
1670 : integer, intent(in) :: id
1671 : integer, intent(out) :: ierr
1672 0 : call do_show_log_description(id, ierr)
1673 0 : end subroutine show_log_description
1674 :
1675 :
1676 : ! write the terminal header lines
1677 1 : subroutine show_terminal_header(id, ierr)
1678 0 : use do_one_utils, only: do_show_terminal_header
1679 : integer, intent(in) :: id
1680 : integer, intent(out) :: ierr
1681 : type (star_info), pointer :: s
1682 : ierr = 0
1683 1 : call star_ptr(id, s, ierr)
1684 1 : if (ierr /= 0) return
1685 1 : call do_show_terminal_header(s)
1686 1 : end subroutine show_terminal_header
1687 :
1688 :
1689 : ! write the terminal summary lines
1690 1 : subroutine write_terminal_summary(id, ierr)
1691 1 : use do_one_utils, only: do_terminal_summary
1692 : integer, intent(in) :: id
1693 : integer, intent(out) :: ierr
1694 : type (star_info), pointer :: s
1695 : ierr = 0
1696 1 : call star_ptr(id, s, ierr)
1697 1 : if (ierr /= 0) return
1698 1 : call do_terminal_summary(s)
1699 1 : end subroutine write_terminal_summary
1700 :
1701 :
1702 0 : subroutine star_set_vars(id, dt, ierr)
1703 1 : use hydro_vars, only: set_vars
1704 : integer, intent(in) :: id
1705 : real(dp), intent(in) :: dt
1706 : integer, intent(out) :: ierr
1707 : type (star_info), pointer :: s
1708 : ierr = 0
1709 0 : call star_ptr(id, s, ierr)
1710 0 : if (ierr /= 0) return
1711 0 : call set_vars(s, dt, ierr)
1712 0 : end subroutine star_set_vars
1713 :
1714 :
1715 0 : subroutine star_set_power_info(s)
1716 0 : use report, only: set_power_info
1717 : type (star_info), pointer :: s
1718 0 : call set_power_info(s)
1719 0 : end subroutine star_set_power_info
1720 :
1721 :
1722 1 : subroutine save_profile(id, priority, ierr)
1723 0 : use profile, only: do_save_profiles
1724 : integer, intent(in) :: id
1725 : integer, intent(in) :: priority
1726 : ! there is a limit to how many profiles are saved,
1727 : ! and lower priority models are discarded if necessary
1728 : ! to make room for higher priority ones.
1729 : integer, intent(out) :: ierr
1730 : type (star_info), pointer :: s
1731 : ierr = 0
1732 1 : call star_ptr(id, s, ierr)
1733 1 : if (ierr /= 0) return
1734 1 : s% save_profiles_model_priority = priority
1735 1 : call do_save_profiles(s, ierr)
1736 1 : end subroutine save_profile
1737 :
1738 :
1739 0 : subroutine star_write_profile_info(id, fname, ierr)
1740 1 : use profile, only: write_profile_info
1741 : integer, intent(in) :: id
1742 : character (len=*) :: fname
1743 : integer, intent(out) :: ierr
1744 : type (star_info), pointer :: s
1745 : ierr = 0
1746 0 : call star_ptr(id, s, ierr)
1747 0 : if (ierr /= 0) return
1748 0 : call write_profile_info(s, fname, ierr)
1749 0 : end subroutine star_write_profile_info
1750 :
1751 :
1752 0 : subroutine name_for_restart_file(val, photo_digits, num_string)
1753 : integer, intent(in) :: val, photo_digits
1754 : character (len=*), intent(out) :: num_string
1755 0 : call string_for_model_number('x', val, photo_digits, num_string)
1756 0 : end subroutine name_for_restart_file
1757 :
1758 :
1759 0 : subroutine string_for_model_number(prefix, n, num_digits, num_string)
1760 : use star_utils, only: get_string_for_model_number
1761 : character (len=*), intent(in) :: prefix
1762 : integer, intent(in) :: n, num_digits
1763 : character (len=*), intent(out) :: num_string
1764 0 : call get_string_for_model_number(prefix, n, num_digits, num_string)
1765 0 : end subroutine string_for_model_number
1766 :
1767 :
1768 : ! a lightweight replacement for star_check_model
1769 0 : integer function bare_bones_check_model(id)
1770 0 : use do_one_utils, only: do_bare_bones_check_model
1771 : integer, intent(in) :: id
1772 0 : bare_bones_check_model = do_bare_bones_check_model(id)
1773 0 : end function bare_bones_check_model
1774 :
1775 :
1776 : ! get a value using the profile column id to specify
1777 0 : real(dp) function val_for_profile(s, c, k)
1778 0 : use profile_getval, only: getval_for_profile
1779 : type (star_info), pointer :: s
1780 : integer, intent(in) :: c ! one of the values like p_logL defined in star_def
1781 : integer, intent(in) :: k ! the zone number
1782 : logical :: int_flag
1783 : integer :: int_val
1784 0 : call getval_for_profile(s, c, k, val_for_profile, int_flag, int_val)
1785 0 : if (int_flag) val_for_profile = dble(int_val)
1786 0 : end function val_for_profile
1787 :
1788 :
1789 : ! get number of zones in current model
1790 0 : integer function star_zones(id, ierr)
1791 : integer, intent(in) :: id
1792 : integer, intent(out) :: ierr
1793 : type (star_info), pointer :: s
1794 0 : call star_ptr(id, s, ierr)
1795 0 : if (ierr /= 0) then
1796 0 : star_zones = -1
1797 : return
1798 : end if
1799 0 : star_zones = s% nz
1800 0 : end function star_zones
1801 :
1802 :
1803 0 : real(dp) function get_current_y(id, ierr)
1804 : use star_utils, only: eval_current_y
1805 : integer, intent(in) :: id
1806 : integer, intent(out) :: ierr
1807 : type (star_info), pointer :: s
1808 0 : call star_ptr(id, s, ierr)
1809 0 : if (ierr /= 0) then
1810 0 : get_current_y = -1
1811 : return
1812 : end if
1813 0 : get_current_y = eval_current_y(s, 1, s% nz, ierr)
1814 0 : end function get_current_y
1815 :
1816 :
1817 0 : real(dp) function get_current_y_in_section(id, nzlo, nzhi, ierr)
1818 0 : use star_utils, only: eval_current_y
1819 : integer, intent(in) :: id
1820 : integer, intent(in) :: nzlo, nzhi ! consider only zones nzlo to nzhi inclusive
1821 : integer, intent(out) :: ierr
1822 : type (star_info), pointer :: s
1823 0 : call star_ptr(id, s, ierr)
1824 0 : if (ierr /= 0) then
1825 0 : get_current_y_in_section = -1
1826 : return
1827 : end if
1828 0 : get_current_y_in_section = eval_current_y(s, nzlo, nzhi, ierr)
1829 0 : end function get_current_y_in_section
1830 :
1831 :
1832 0 : real(dp) function get_current_y_at_point(id, k, ierr)
1833 0 : use star_utils, only: eval_current_y
1834 : integer, intent(in) :: id
1835 : integer, intent(in) :: k ! between 1 and nz
1836 : integer, intent(out) :: ierr
1837 : type (star_info), pointer :: s
1838 0 : call star_ptr(id, s, ierr)
1839 0 : if (ierr /= 0) then
1840 0 : get_current_y_at_point = -1
1841 : return
1842 : end if
1843 0 : get_current_y_at_point = eval_current_y(s, k, k, ierr)
1844 0 : end function get_current_y_at_point
1845 :
1846 :
1847 0 : real(dp) function get_current_z(id, ierr)
1848 0 : use star_utils, only: eval_current_z
1849 : integer, intent(in) :: id
1850 : integer, intent(out) :: ierr
1851 : type (star_info), pointer :: s
1852 0 : call star_ptr(id, s, ierr)
1853 0 : if (ierr /= 0) then
1854 0 : get_current_z = -1
1855 : return
1856 : end if
1857 0 : get_current_z = eval_current_z(s, 1, s% nz, ierr)
1858 0 : end function get_current_z
1859 :
1860 :
1861 0 : real(dp) function get_current_z_in_section(id, nzlo, nzhi, ierr)
1862 0 : use star_utils, only: eval_current_z
1863 : integer, intent(in) :: id
1864 : integer, intent(in) :: nzlo, nzhi ! consider only zones nzlo to nzhi inclusive
1865 : integer, intent(out) :: ierr
1866 : type (star_info), pointer :: s
1867 0 : call star_ptr(id, s, ierr)
1868 0 : if (ierr /= 0) then
1869 0 : get_current_z_in_section = -1
1870 : return
1871 : end if
1872 0 : get_current_z_in_section = eval_current_z(s, nzlo, nzhi, ierr)
1873 0 : end function get_current_z_in_section
1874 :
1875 :
1876 0 : real(dp) function get_current_z_at_point(id, k, ierr)
1877 0 : use star_utils, only: eval_current_z
1878 : integer, intent(in) :: id
1879 : integer, intent(in) :: k ! between 1 and nz
1880 : integer, intent(out) :: ierr
1881 : type (star_info), pointer :: s
1882 0 : call star_ptr(id, s, ierr)
1883 0 : if (ierr /= 0) then
1884 0 : get_current_z_at_point = -1
1885 : return
1886 : end if
1887 0 : get_current_z_at_point = eval_current_z(s, k, k, ierr)
1888 0 : end function get_current_z_at_point
1889 :
1890 :
1891 0 : real(dp) function get_current_abundance(id, iso, ierr)
1892 : ! returns mass fraction for iso
1893 0 : use star_utils, only: eval_current_abundance
1894 : integer, intent(in) :: id
1895 : integer, intent(in) :: iso ! chem id from chem_def
1896 : integer, intent(out) :: ierr
1897 : type (star_info), pointer :: s
1898 0 : call star_ptr(id, s, ierr)
1899 0 : if (ierr /= 0) then
1900 0 : get_current_abundance = -1
1901 : return
1902 : end if
1903 : get_current_abundance = &
1904 0 : eval_current_abundance(s, s% net_iso(iso), 1, s% nz, ierr)
1905 0 : end function get_current_abundance
1906 :
1907 :
1908 11 : real(dp) function current_abundance_in_section(id, iso, nzlo, nzhi, ierr)
1909 : ! returns mass fraction for iso
1910 0 : use star_utils, only: eval_current_abundance
1911 : integer, intent(in) :: id
1912 : integer, intent(in) :: iso ! chem id from chem_def
1913 : integer, intent(in) :: nzlo, nzhi ! consider only zones nzlo to nzhi inclusive
1914 : integer, intent(out) :: ierr
1915 : type (star_info), pointer :: s
1916 11 : call star_ptr(id, s, ierr)
1917 11 : if (ierr /= 0) then
1918 11 : current_abundance_in_section = -1
1919 : return
1920 : end if
1921 : current_abundance_in_section = &
1922 11 : eval_current_abundance(s, s% net_iso(iso), nzlo, nzhi, ierr)
1923 11 : end function current_abundance_in_section
1924 :
1925 :
1926 11 : real(dp) function current_abundance_at_point(id, iso, k, ierr)
1927 : ! returns mass fraction for iso
1928 11 : use star_utils, only: eval_current_abundance
1929 : integer, intent(in) :: id
1930 : integer, intent(in) :: iso ! chem id from chem_def
1931 : integer, intent(in) :: k
1932 : integer, intent(out) :: ierr
1933 11 : current_abundance_at_point = current_abundance_in_section(id, iso, k, k, ierr)
1934 11 : end function current_abundance_at_point
1935 :
1936 :
1937 0 : subroutine star_get_XYZ(id, xa, X, Y, Z, ierr)
1938 11 : use star_utils, only: get_XYZ
1939 : integer, intent(in) :: id
1940 : real(dp), intent(in) :: xa(:)
1941 : real(dp), intent(out) :: X, Y, Z
1942 : integer, intent(out) :: ierr
1943 : type (star_info), pointer :: s
1944 : ierr = 0
1945 0 : call star_ptr(id, s, ierr)
1946 0 : if (ierr /= 0) return
1947 0 : call get_XYZ(s, xa, X, Y, Z)
1948 0 : end subroutine star_get_XYZ
1949 :
1950 :
1951 0 : subroutine star_xa_for_standard_metals( &
1952 0 : s, species, chem_id, net_iso, &
1953 : h1, h2, he3, he4, which_zfracs, &
1954 0 : dump_missing_metals_into_heaviest, xa, ierr)
1955 0 : use adjust_xyz, only: get_xa_for_standard_metals
1956 : type (star_info), pointer :: s
1957 : integer, intent(in) :: species, chem_id(:), net_iso(:), which_zfracs
1958 : real(dp), intent(in) :: h1, h2, he3, he4 ! mass fractions
1959 : logical, intent(in) :: dump_missing_metals_into_heaviest
1960 : real(dp), intent(inout) :: xa(:) ! (species)
1961 : integer, intent(out) :: ierr
1962 : call get_xa_for_standard_metals( &
1963 : s, species, chem_id, net_iso, &
1964 : h1, h2, he3, he4, which_zfracs, &
1965 0 : dump_missing_metals_into_heaviest, xa, ierr)
1966 0 : end subroutine star_xa_for_standard_metals
1967 :
1968 :
1969 0 : subroutine star_info_at_q(s, q, &
1970 : kbdy, m, r, lgT, lgRho, L, v, &
1971 : lgP, g, X, Y, scale_height, dlnX_dr, dlnY_dr, dlnRho_dr, &
1972 : omega, omega_div_omega_crit)
1973 0 : use report, only: get_info_at_q
1974 : type (star_info), pointer :: s
1975 : real(dp), intent(in) :: q ! relative mass coord
1976 : integer, intent(out) :: kbdy
1977 : real(dp), intent(out) :: &
1978 : m, r, lgT, lgRho, L, v, &
1979 : lgP, g, X, Y, scale_height, dlnX_dr, dlnY_dr, dlnRho_dr, &
1980 : omega, omega_div_omega_crit
1981 : call get_info_at_q(s, q, &
1982 : kbdy, m, r, lgT, lgRho, L, v, &
1983 : lgP, g, X, Y, scale_height, dlnX_dr, dlnY_dr, dlnRho_dr, &
1984 0 : omega, omega_div_omega_crit)
1985 0 : end subroutine star_info_at_q
1986 :
1987 :
1988 12 : integer function get_model_number(id, ierr)
1989 : integer, intent(in) :: id
1990 : integer, intent(out) :: ierr
1991 : type (star_info), pointer :: s
1992 12 : call star_ptr(id, s, ierr)
1993 12 : if (ierr /= 0) then
1994 12 : get_model_number = -1
1995 : return
1996 : end if
1997 12 : get_model_number = s% model_number
1998 12 : end function get_model_number
1999 :
2000 :
2001 0 : logical function check_for_after_He_burn(s, he4_limit)
2002 : use star_utils, only: after_He_burn
2003 : type (star_info), pointer :: s
2004 : real(dp), intent(in) :: he4_limit
2005 0 : check_for_after_He_burn = after_He_burn(s, he4_limit)
2006 0 : end function check_for_after_He_burn
2007 :
2008 :
2009 0 : logical function check_for_after_C_burn(s, c12_limit)
2010 0 : use star_utils, only: after_C_burn
2011 : type (star_info), pointer :: s
2012 : real(dp), intent(in) :: c12_limit
2013 0 : check_for_after_C_burn = after_C_burn(s, c12_limit)
2014 0 : end function check_for_after_C_burn
2015 :
2016 :
2017 : ! intrinsic variables like T, Rho, kap, etc. are cell averages
2018 : ! this routine returns an interpolated value at outer boundary of cell k
2019 0 : real(dp) function star_interp_val_to_pt(v,k,sz,dq,debug_str)
2020 0 : use star_utils, only: interp_val_to_pt
2021 : integer, intent(in) :: k, sz
2022 : real(dp), pointer :: v(:), dq(:) ! (sz)
2023 : character (len=*), intent(in) :: debug_str
2024 0 : star_interp_val_to_pt = interp_val_to_pt(v,k,sz,dq,debug_str)
2025 0 : end function star_interp_val_to_pt
2026 :
2027 :
2028 : ! this routine returns an interpolated value of xa(j,:) at outer boundary of cell k
2029 0 : real(dp) function star_interp_xa_to_pt(xa,j,k,sz,dq,debug_str)
2030 0 : use star_utils, only: interp_xa_to_pt
2031 : real(dp), pointer :: xa(:,:), dq(:) ! (sz)
2032 : integer, intent(in) :: j, k, sz
2033 : character (len=*), intent(in) :: debug_str
2034 0 : star_interp_xa_to_pt = interp_xa_to_pt(xa,j,k,sz,dq,debug_str)
2035 0 : end function star_interp_xa_to_pt
2036 : ! misc routines
2037 :
2038 :
2039 0 : subroutine star_set_xqs(nz, xq, dq, ierr) ! set xq's using dq's
2040 0 : use star_utils, only: set_xqs
2041 : integer, intent(in) :: nz
2042 : real(dp), intent(inout) :: dq(:) ! (nz)
2043 : real(dp), intent(inout) :: xq(:) ! (nz)
2044 : integer, intent(out) :: ierr
2045 0 : call set_xqs(nz, xq, dq, ierr)
2046 0 : end subroutine star_set_xqs
2047 :
2048 :
2049 0 : subroutine star_get_eos( &
2050 0 : id, k, xa, &
2051 : Rho, logRho, T, logT, &
2052 : res, dres_dlnRho, dres_dlnT, &
2053 0 : dres_dxa, ierr)
2054 0 : use eos_def, only: num_eos_basic_results
2055 : use eos_support, only: get_eos
2056 : integer, intent(in) :: id
2057 : integer, intent(in) :: k ! 0 means not being called for a particular cell
2058 : real(dp), intent(in) :: xa(:), Rho, logRho, T, logT
2059 : real(dp), dimension(num_eos_basic_results), intent(out) :: &
2060 : res, dres_dlnRho, dres_dlnT
2061 : real(dp), intent(out) :: dres_dxa(:,:)
2062 : integer, intent(out) :: ierr
2063 : type (star_info), pointer :: s
2064 : ierr = 0
2065 0 : call star_ptr(id, s, ierr)
2066 0 : if (ierr /= 0) return
2067 : call get_eos( &
2068 : s, k, xa, &
2069 : Rho, logRho, T, logT, &
2070 : res, dres_dlnRho, dres_dlnT, &
2071 0 : dres_dxa, ierr)
2072 0 : end subroutine star_get_eos
2073 :
2074 0 : subroutine star_get_peos( &
2075 : id, k, xa, &
2076 : Pgas, logPgas, T, logT, &
2077 : Rho, logRho, dlnRho_dlnPgas, dlnRho_dlnT, &
2078 : res, dres_dlnRho, dres_dlnT, &
2079 : dres_dxa, ierr)
2080 0 : use eos_def, only: num_eos_basic_results
2081 : !use eos_support, only: get_peos
2082 : integer, intent(in) :: id
2083 : integer, intent(in) :: k ! 0 means not being called for a particular cell
2084 : real(dp), intent(in) :: xa(:), Pgas, logPgas, T, logT
2085 : real(dp), intent(out) :: &
2086 : Rho, logRho, dlnRho_dlnPgas, dlnRho_dlnT
2087 : real(dp), dimension(num_eos_basic_results), intent(out) :: &
2088 : res, dres_dlnRho, dres_dlnT
2089 : real(dp), intent(out) :: dres_dxa(:,:)
2090 : integer, intent(out) :: ierr
2091 : !type (star_info), pointer :: s
2092 : !ierr = 0
2093 : !call star_ptr(id, s, ierr)
2094 : !if (ierr /= 0) return
2095 : !call get_peos ( &
2096 : ! s, k, xa, &
2097 : ! Pgas, logPgas, T, logT, &
2098 : ! Rho, logRho, dlnRho_dlnPgas, dlnRho_dlnT, &
2099 : ! res, dres_dlnRho, dres_dlnT, dres_dxa, ierr)
2100 0 : ierr = -1
2101 0 : write(*,*) 'star_get_peos no longer supported'
2102 0 : call mesa_error(__FILE__,__LINE__)
2103 0 : end subroutine star_get_peos
2104 :
2105 0 : subroutine star_solve_eos_given_PgasT( &
2106 0 : id, k, xa, &
2107 : logT, logPgas, logRho_guess, logRho_tol, logPgas_tol, &
2108 0 : logRho, res, dres_dlnRho, dres_dlnT, dres_dxa, &
2109 : ierr)
2110 0 : use eos_def, only: num_eos_basic_results, num_eos_d_dxa_results
2111 : use eos_support, only : solve_eos_given_PgasT
2112 : integer, intent(in) :: id
2113 : integer, intent(in) :: k ! 0 indicates not for a particular cell.
2114 : real(dp), intent(in) :: &
2115 : xa(:), logT, logPgas, &
2116 : logRho_guess, logRho_tol, logPgas_tol
2117 : real(dp), intent(out) :: logRho
2118 : real(dp), dimension(num_eos_basic_results), intent(out) :: &
2119 : res, dres_dlnRho, dres_dlnT
2120 : real(dp), dimension(:,:), intent(out) :: dres_dxa
2121 : integer, intent(out) :: ierr
2122 : type (star_info), pointer :: s
2123 : ierr = 0
2124 0 : call star_ptr(id, s, ierr)
2125 0 : if (ierr /= 0) return
2126 : call solve_eos_given_PgasT( &
2127 : s, k, xa, &
2128 : logT, logPgas, logRho_guess, logRho_tol, logPgas_tol, &
2129 : logRho, res, dres_dlnRho, dres_dlnT, dres_dxa, &
2130 0 : ierr)
2131 0 : end subroutine star_solve_eos_given_PgasT
2132 :
2133 0 : subroutine star_solve_eos_given_PgasT_auto( &
2134 0 : id, k, xa, &
2135 : logT, logPgas, logRho_tol, logPgas_tol, &
2136 0 : logRho, res, dres_dlnRho, dres_dlnT, dres_dxa, &
2137 : ierr)
2138 0 : use eos_def, only: num_eos_basic_results, num_eos_d_dxa_results
2139 : use eos_support, only: solve_eos_given_PgasT_auto
2140 : use star_def
2141 : integer, intent(in) :: id ! id for star
2142 : integer, intent(in) :: k ! 0 indicates not for a particular cell.
2143 : real(dp), intent(in) :: &
2144 : xa(:), logT, logPgas, &
2145 : logRho_tol, logPgas_tol
2146 : real(dp), intent(out) :: logRho
2147 : real(dp), dimension(num_eos_basic_results), intent(out) :: &
2148 : res, dres_dlnRho, dres_dlnT
2149 : real(dp), dimension(:,:), intent(out) :: dres_dxa
2150 : integer, intent(out) :: ierr
2151 : type (star_info), pointer :: s
2152 0 : call star_ptr(id, s, ierr)
2153 0 : if (ierr /= 0) return
2154 : call solve_eos_given_PgasT_auto( &
2155 : s, k, xa, &
2156 : logT, logPgas, logRho_tol, logPgas_tol, &
2157 : logRho, res, dres_dlnRho, dres_dlnT, dres_dxa, &
2158 0 : ierr)
2159 0 : end subroutine star_solve_eos_given_PgasT_auto
2160 :
2161 0 : subroutine star_get_kap( &
2162 : id, k, zbar, xa, logRho, logT, &
2163 : lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT, &
2164 : eta, deta_dlnRho, deta_dlnT, &
2165 : kap_fracs, kap, dlnkap_dlnRho, dlnkap_dlnT, ierr)
2166 0 : use kap_def, only: num_kap_fracs
2167 : use kap_support, only: get_kap, fraction_of_op_mono
2168 : integer, intent(in) :: id
2169 : integer, intent(in) :: k
2170 : real(dp), intent(in) :: zbar, logRho, logT, &
2171 : lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT, &
2172 : eta, deta_dlnRho, deta_dlnT
2173 : real(dp), intent(in), pointer :: xa(:)
2174 : real(dp), intent(out) :: kap_fracs(num_kap_fracs)
2175 : real(dp), intent(out) :: kap, dlnkap_dlnRho, dlnkap_dlnT
2176 : integer, intent(out) :: ierr
2177 : type (star_info), pointer :: s
2178 : ierr = 0
2179 0 : call star_ptr(id, s, ierr)
2180 0 : if (ierr /= 0) return
2181 : call get_kap( &
2182 : s, k, zbar, xa, logRho, logT, &
2183 : lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT, &
2184 : eta, deta_dlnRho, deta_dlnT, &
2185 0 : kap_fracs, kap, dlnkap_dlnRho, dlnkap_dlnT, ierr)
2186 0 : end subroutine star_get_kap
2187 :
2188 0 : subroutine star_do_eos_for_cell(id, k, ierr)
2189 0 : use micro, only: do_eos_for_cell
2190 : integer, intent(in) :: id
2191 : integer, intent(in) :: k
2192 : integer, intent(out) :: ierr
2193 : type (star_info), pointer :: s
2194 : ierr = 0
2195 0 : call star_ptr(id, s, ierr)
2196 0 : if (ierr /= 0) return
2197 0 : call do_eos_for_cell(s, k, ierr)
2198 0 : end subroutine star_do_eos_for_cell
2199 :
2200 :
2201 0 : subroutine star_do_kap_for_cell(id, k, ierr)
2202 0 : use micro, only: do_kap_for_cell
2203 : integer, intent(in) :: id
2204 : integer, intent(in) :: k
2205 : integer, intent(out) :: ierr
2206 : type (star_info), pointer :: s
2207 : ierr = 0
2208 0 : call star_ptr(id, s, ierr)
2209 0 : if (ierr /= 0) return
2210 0 : call do_kap_for_cell(s, k, ierr)
2211 0 : end subroutine star_do_kap_for_cell
2212 :
2213 :
2214 0 : subroutine star_get_atm_PT( &
2215 : id, tau_surf, L, R, M, cgrav, skip_partials, Teff, &
2216 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2217 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap, &
2218 : ierr)
2219 0 : use atm_support, only: get_atm_PT
2220 : integer, intent(in) :: id
2221 : real(dp), intent(in) :: tau_surf, L, R, M, cgrav
2222 : logical, intent(in) :: skip_partials
2223 : real(dp), intent(in) :: Teff
2224 : real(dp), intent(out) :: &
2225 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2226 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap
2227 : integer, intent(out) :: ierr
2228 : type (star_info), pointer :: s
2229 : ierr = 0
2230 0 : call star_ptr(id, s, ierr)
2231 0 : if (ierr /= 0) return
2232 : call get_atm_PT( &
2233 : s, tau_surf, L, R, M, cgrav, skip_partials, &
2234 : Teff, &
2235 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2236 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap, &
2237 0 : ierr)
2238 0 : end subroutine star_get_atm_PT
2239 :
2240 :
2241 0 : subroutine star_get_surf_PT( &
2242 : id, skip_partials, need_atm_Psurf, need_atm_Tsurf, &
2243 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2244 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap, &
2245 : ierr)
2246 0 : use hydro_vars, only: get_surf_PT
2247 : integer, intent(in) :: id
2248 : logical, intent(in) :: skip_partials, need_atm_Psurf, need_atm_Tsurf
2249 : real(dp), intent(out) :: &
2250 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2251 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap
2252 : integer, intent(out) :: ierr
2253 : type (star_info), pointer :: s
2254 : ierr = 0
2255 0 : call star_ptr(id, s, ierr)
2256 0 : if (ierr /= 0) return
2257 : call get_surf_PT( &
2258 : s, skip_partials, need_atm_Psurf, need_atm_Tsurf, &
2259 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2260 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap, &
2261 0 : ierr)
2262 0 : end subroutine star_get_surf_PT
2263 :
2264 0 : integer function get_result_reason(id, ierr)
2265 : integer, intent(in) :: id
2266 : integer, intent(out) :: ierr
2267 : type (star_info), pointer :: s
2268 0 : call star_ptr(id, s, ierr)
2269 0 : if (ierr /= 0) then
2270 0 : get_result_reason = -1
2271 : return
2272 : end if
2273 0 : get_result_reason = s% result_reason
2274 0 : end function get_result_reason
2275 :
2276 0 : real(dp) function eval_tau_at_r(id, r, ierr)
2277 : ! optical depth tau at radius r (cm)
2278 : ! r should be <= s% r(1) and >= s% Rcenter
2279 : ! does linear interpolation wrt r within cell
2280 : use star_utils, only: get_tau_at_r
2281 : integer, intent(in) :: id
2282 : real(dp), intent(in) :: r
2283 : integer, intent(out) :: ierr
2284 : type (star_info), pointer :: s
2285 0 : call star_ptr(id, s, ierr)
2286 0 : if (ierr /= 0) then
2287 0 : eval_tau_at_r = -1
2288 : return
2289 : end if
2290 0 : eval_tau_at_r = get_tau_at_r(s, r, ierr)
2291 0 : end function eval_tau_at_r
2292 :
2293 :
2294 0 : real(dp) function eval_total_times(id, ierr)
2295 0 : use star_utils, only: total_times
2296 : integer, intent(in) :: id
2297 : integer, intent(out) :: ierr
2298 : type (star_info), pointer :: s
2299 0 : call star_ptr(id, s, ierr)
2300 0 : if (ierr /= 0) then
2301 0 : eval_total_times = -1
2302 : return
2303 : end if
2304 0 : eval_total_times = total_times(s)
2305 0 : end function eval_total_times
2306 :
2307 :
2308 0 : subroutine star_total_energy_integrals(id, &
2309 : total_internal_energy, total_gravitational_energy, &
2310 : total_radial_kinetic_energy, total_rotational_kinetic_energy, &
2311 : total_turbulent_energy, sum_total, ierr)
2312 0 : use star_utils, only: eval_total_energy_integrals
2313 : integer, intent(in) :: id
2314 : real(dp), intent(out) :: &
2315 : total_internal_energy, total_gravitational_energy, &
2316 : total_radial_kinetic_energy, total_rotational_kinetic_energy, &
2317 : total_turbulent_energy, sum_total
2318 : integer, intent(out) :: ierr
2319 : type (star_info), pointer :: s
2320 0 : call star_ptr(id, s, ierr)
2321 0 : if (ierr /= 0) return
2322 : call eval_total_energy_integrals(s, &
2323 : total_internal_energy, total_gravitational_energy, &
2324 : total_radial_kinetic_energy, total_rotational_kinetic_energy, &
2325 0 : total_turbulent_energy, sum_total)
2326 0 : end subroutine star_total_energy_integrals
2327 :
2328 :
2329 0 : real(dp) function star_surface_omega_crit(id, ierr)
2330 0 : use hydro_rotation, only: set_surf_avg_rotation_info
2331 : integer, intent(in) :: id
2332 : integer, intent(out) :: ierr
2333 : type (star_info), pointer :: s
2334 0 : call star_ptr(id, s, ierr)
2335 0 : if (ierr /= 0) then
2336 0 : star_surface_omega_crit = -1
2337 : return
2338 : end if
2339 0 : call set_surf_avg_rotation_info(s)
2340 0 : star_surface_omega_crit = s% omega_crit_avg_surf
2341 0 : end function star_surface_omega_crit
2342 :
2343 :
2344 : ! some routines for "stellar engineering"
2345 :
2346 0 : subroutine star_normalize_dqs(id, nz, dq, ierr)
2347 : ! rescale dq's so that add to 1.000
2348 : ! work in from boundaries to meet at largest dq
2349 0 : use star_utils, only: normalize_dqs
2350 : integer, intent(in) :: id
2351 : integer, intent(in) :: nz
2352 : real(dp), intent(inout) :: dq(:) ! (nz)
2353 : integer, intent(out) :: ierr
2354 : type (star_info), pointer :: s
2355 0 : call star_ptr(id, s, ierr)
2356 0 : if (ierr /= 0) return
2357 0 : call normalize_dqs(s, nz, dq, ierr)
2358 0 : end subroutine star_normalize_dqs
2359 :
2360 :
2361 0 : subroutine star_set_qs(id, nz, q, dq, ierr) ! set q's using normalized dq's
2362 0 : use star_utils, only: set_qs
2363 : integer, intent(in) :: id
2364 : integer, intent(in) :: nz
2365 : real(dp), intent(inout) :: dq(:) ! (nz)
2366 : real(dp), intent(inout) :: q(:) ! (nz)
2367 : integer, intent(out) :: ierr
2368 : type (star_info), pointer :: s
2369 0 : call star_ptr(id, s, ierr)
2370 0 : if (ierr /= 0) return
2371 0 : call set_qs(s, nz, q, dq, ierr)
2372 0 : end subroutine star_set_qs
2373 :
2374 :
2375 0 : subroutine star_set_m_and_dm(id, ierr)
2376 0 : use star_utils, only: set_m_and_dm
2377 : integer, intent(in) :: id
2378 : integer, intent(out) :: ierr
2379 : type (star_info), pointer :: s
2380 : ierr = 0
2381 0 : call star_ptr(id, s, ierr)
2382 0 : if (ierr /= 0) return
2383 0 : call set_m_and_dm(s)
2384 0 : end subroutine star_set_m_and_dm
2385 :
2386 :
2387 0 : subroutine star_set_dm_bar(id, ierr)
2388 0 : use star_utils, only: set_dm_bar
2389 : integer, intent(in) :: id
2390 : integer, intent(out) :: ierr
2391 : type (star_info), pointer :: s
2392 : ierr = 0
2393 0 : call star_ptr(id, s, ierr)
2394 0 : if (ierr /= 0) return
2395 0 : call set_dm_bar(s, s% nz, s% dm, s% dm_bar)
2396 0 : end subroutine star_set_dm_bar
2397 :
2398 :
2399 0 : subroutine star_remove_center_at_cell_k(id, k, ierr)
2400 0 : use remove_shells, only: do_remove_center_at_cell_k
2401 : integer, intent(in) :: id, k
2402 : integer, intent(out) :: ierr
2403 0 : call do_remove_center_at_cell_k(id, k, ierr)
2404 0 : end subroutine star_remove_center_at_cell_k
2405 :
2406 :
2407 0 : subroutine star_remove_center_by_temperature(id, temperature, ierr)
2408 0 : use remove_shells, only: do_remove_center_by_temperature
2409 : integer, intent(in) :: id
2410 : real(dp), intent(in) :: temperature
2411 : integer, intent(out) :: ierr
2412 0 : call do_remove_center_by_temperature(id, temperature, ierr)
2413 0 : end subroutine star_remove_center_by_temperature
2414 :
2415 :
2416 0 : subroutine star_remove_center_by_radius_cm(id, r_cm, ierr)
2417 0 : use remove_shells, only: do_remove_center_by_radius_cm
2418 : integer, intent(in) :: id
2419 : real(dp), intent(in) :: r_cm
2420 : integer, intent(out) :: ierr
2421 0 : call do_remove_center_by_radius_cm(id, r_cm, ierr)
2422 0 : end subroutine star_remove_center_by_radius_cm
2423 :
2424 :
2425 0 : subroutine star_remove_center_by_mass_fraction_q(id, q, ierr)
2426 0 : use remove_shells, only: do_remove_inner_fraction_q
2427 : integer, intent(in) :: id
2428 : real(dp), intent(in) :: q
2429 : integer, intent(out) :: ierr
2430 0 : call do_remove_inner_fraction_q(id, q, ierr)
2431 0 : end subroutine star_remove_center_by_mass_fraction_q
2432 :
2433 :
2434 0 : subroutine star_remove_center_by_he4(id, x, ierr)
2435 0 : use remove_shells, only: do_remove_center_by_he4
2436 : integer, intent(in) :: id
2437 : real(dp), intent(in) :: x ! mass fraction
2438 : integer, intent(out) :: ierr
2439 0 : call do_remove_center_by_he4(id, x, ierr)
2440 0 : end subroutine star_remove_center_by_he4
2441 :
2442 :
2443 0 : subroutine star_remove_center_by_c12_o16(id, x, ierr)
2444 0 : use remove_shells, only: do_remove_center_by_c12_o16
2445 : integer, intent(in) :: id
2446 : real(dp), intent(in) :: x ! mass fraction
2447 : integer, intent(out) :: ierr
2448 0 : call do_remove_center_by_c12_o16(id, x, ierr)
2449 0 : end subroutine star_remove_center_by_c12_o16
2450 :
2451 :
2452 0 : subroutine star_remove_center_by_si28(id, x, ierr)
2453 0 : use remove_shells, only: do_remove_center_by_si28
2454 : integer, intent(in) :: id
2455 : real(dp), intent(in) :: x ! mass fraction
2456 : integer, intent(out) :: ierr
2457 0 : call do_remove_center_by_si28(id, x, ierr)
2458 0 : end subroutine star_remove_center_by_si28
2459 :
2460 :
2461 0 : subroutine star_remove_center_to_reduce_co56_ni56(id, x, ierr)
2462 0 : use remove_shells, only: do_remove_center_to_reduce_co56_ni56
2463 : integer, intent(in) :: id
2464 : real(dp), intent(in) :: x ! mass fraction
2465 : integer, intent(out) :: ierr
2466 0 : call do_remove_center_to_reduce_co56_ni56(id, x, ierr)
2467 0 : end subroutine star_remove_center_to_reduce_co56_ni56
2468 :
2469 :
2470 0 : subroutine star_remove_center_by_ye(id, ye, ierr)
2471 0 : use remove_shells, only: do_remove_center_by_ye
2472 : integer, intent(in) :: id
2473 : real(dp), intent(in) :: ye
2474 : integer, intent(out) :: ierr
2475 0 : call do_remove_center_by_ye(id, ye, ierr)
2476 0 : end subroutine star_remove_center_by_ye
2477 :
2478 :
2479 0 : subroutine star_remove_center_by_entropy(id, entropy, ierr)
2480 0 : use remove_shells, only: do_remove_center_by_entropy
2481 : integer, intent(in) :: id
2482 : real(dp), intent(in) :: entropy
2483 : integer, intent(out) :: ierr
2484 0 : call do_remove_center_by_entropy(id, entropy, ierr)
2485 0 : end subroutine star_remove_center_by_entropy
2486 :
2487 :
2488 0 : subroutine star_remove_center_by_infall_kms(id, infall_kms, ierr)
2489 0 : use remove_shells, only: do_remove_center_by_infall_kms
2490 : integer, intent(in) :: id
2491 : real(dp), intent(in) :: infall_kms
2492 : integer, intent(out) :: ierr
2493 0 : call do_remove_center_by_infall_kms(id, infall_kms, ierr)
2494 0 : end subroutine star_remove_center_by_infall_kms
2495 :
2496 :
2497 0 : subroutine star_remove_center_at_inner_max_abs_v(id, ierr)
2498 0 : use remove_shells, only: do_remove_center_at_inner_max_abs_v
2499 : integer, intent(in) :: id
2500 : integer, intent(out) :: ierr
2501 0 : call do_remove_center_at_inner_max_abs_v(id, ierr)
2502 0 : end subroutine star_remove_center_at_inner_max_abs_v
2503 :
2504 :
2505 0 : subroutine star_remove_fe_core(id, ierr)
2506 0 : use remove_shells, only: do_remove_fe_core
2507 : integer, intent(in) :: id
2508 : integer, intent(out) :: ierr
2509 0 : call do_remove_fe_core(id, ierr)
2510 0 : end subroutine star_remove_fe_core
2511 :
2512 :
2513 0 : subroutine star_remove_center_by_mass_gm(id, m, ierr)
2514 0 : use remove_shells, only: do_remove_center_by_mass_gm
2515 : integer, intent(in) :: id
2516 : real(dp), intent(in) :: m
2517 : integer, intent(out) :: ierr
2518 0 : call do_remove_center_by_mass_gm(id, m, ierr)
2519 0 : end subroutine star_remove_center_by_mass_gm
2520 :
2521 :
2522 0 : subroutine star_zero_inner_v_by_mass_gm(id, m, ierr)
2523 0 : use remove_shells, only: do_zero_inner_v_by_mass_gm
2524 : integer, intent(in) :: id
2525 : real(dp), intent(in) :: m
2526 : integer, intent(out) :: ierr
2527 0 : call do_zero_inner_v_by_mass_gm(id, m, ierr)
2528 0 : end subroutine star_zero_inner_v_by_mass_gm
2529 :
2530 :
2531 0 : subroutine star_relax_to_star_cut(&
2532 : id, k_remove, do_jrot, do_entropy, turn_off_energy_sources_and_sinks, ierr)
2533 0 : use remove_shells, only: do_relax_to_star_cut
2534 :
2535 : integer, intent(in) :: id, k_remove
2536 : logical, intent(in) :: do_jrot, do_entropy
2537 : logical, intent(in) :: turn_off_energy_sources_and_sinks ! determines if we turn off non_nuc_neu and eps_nuc for entropy relax
2538 : integer, intent(out) :: ierr
2539 :
2540 0 : call do_relax_to_star_cut(id, k_remove, do_jrot, do_entropy, turn_off_energy_sources_and_sinks, ierr)
2541 0 : end subroutine star_relax_to_star_cut
2542 :
2543 :
2544 0 : subroutine star_remove_surface_by_v_surf_km_s(id, v_surf_km_s, ierr)
2545 0 : use remove_shells, only: do_remove_surface_by_v_surf_km_s
2546 : integer, intent(in) :: id
2547 : real(dp), intent(in) :: v_surf_km_s
2548 : integer, intent(out) :: ierr
2549 0 : call do_remove_surface_by_v_surf_km_s(id, v_surf_km_s, ierr)
2550 0 : end subroutine star_remove_surface_by_v_surf_km_s
2551 :
2552 :
2553 0 : subroutine star_remove_surface_by_v_surf_div_cs(id, v_surf_div_cs, ierr)
2554 0 : use remove_shells, only: do_remove_surface_by_v_surf_div_cs
2555 : integer, intent(in) :: id
2556 : real(dp), intent(in) :: v_surf_div_cs
2557 : integer, intent(out) :: ierr
2558 0 : call do_remove_surface_by_v_surf_div_cs(id, v_surf_div_cs, ierr)
2559 0 : end subroutine star_remove_surface_by_v_surf_div_cs
2560 :
2561 :
2562 0 : subroutine star_remove_surface_by_v_surf_div_v_escape(id, v_surf_div_v_escape, ierr)
2563 0 : use remove_shells, only: do_remove_surface_by_v_surf_div_v_escape
2564 : integer, intent(in) :: id
2565 : real(dp), intent(in) :: v_surf_div_v_escape
2566 : integer, intent(out) :: ierr
2567 0 : call do_remove_surface_by_v_surf_div_v_escape(id, v_surf_div_v_escape, ierr)
2568 0 : end subroutine star_remove_surface_by_v_surf_div_v_escape
2569 :
2570 :
2571 0 : subroutine star_remove_surface_at_cell_k(id, k, ierr)
2572 0 : use remove_shells, only: do_remove_surface_at_cell_k
2573 : integer, intent(in) :: id, k
2574 : integer, intent(out) :: ierr
2575 0 : call do_remove_surface_at_cell_k(id, k, ierr)
2576 0 : end subroutine star_remove_surface_at_cell_k
2577 :
2578 :
2579 0 : subroutine star_remove_surface_at_he_core_boundary(id, h1_fraction, ierr)
2580 0 : use remove_shells, only: do_remove_surface_at_he_core_boundary
2581 : integer, intent(in) :: id
2582 : real(dp), intent(in) :: h1_fraction
2583 : integer, intent(out) :: ierr
2584 0 : call do_remove_surface_at_he_core_boundary(id, h1_fraction, ierr)
2585 0 : end subroutine star_remove_surface_at_he_core_boundary
2586 :
2587 :
2588 0 : subroutine star_remove_surface_by_optical_depth(id, optical_depth, ierr)
2589 0 : use remove_shells, only: do_remove_surface_by_optical_depth
2590 : integer, intent(in) :: id
2591 : real(dp), intent(in) :: optical_depth
2592 : integer, intent(out) :: ierr
2593 0 : call do_remove_surface_by_optical_depth(id, optical_depth, ierr)
2594 0 : end subroutine star_remove_surface_by_optical_depth
2595 :
2596 :
2597 0 : subroutine star_remove_surface_by_density(id, density, ierr)
2598 0 : use remove_shells, only: do_remove_surface_by_density
2599 : integer, intent(in) :: id
2600 : real(dp), intent(in) :: density
2601 : integer, intent(out) :: ierr
2602 0 : call do_remove_surface_by_density(id, density, ierr)
2603 0 : end subroutine star_remove_surface_by_density
2604 :
2605 :
2606 0 : subroutine star_remove_surface_by_pressure(id, pressure, ierr)
2607 0 : use remove_shells, only: do_remove_surface_by_pressure
2608 : integer, intent(in) :: id
2609 : real(dp), intent(in) :: pressure
2610 : integer, intent(out) :: ierr
2611 0 : call do_remove_surface_by_pressure(id, pressure, ierr)
2612 0 : end subroutine star_remove_surface_by_pressure
2613 :
2614 :
2615 0 : subroutine star_remove_surface_by_radius_cm(id, r_cm, ierr)
2616 0 : use remove_shells, only: do_remove_surface_by_radius_cm
2617 : integer, intent(in) :: id
2618 : real(dp), intent(in) :: r_cm
2619 : integer, intent(out) :: ierr
2620 0 : call do_remove_surface_by_radius_cm(id, r_cm, ierr)
2621 0 : end subroutine star_remove_surface_by_radius_cm
2622 :
2623 :
2624 0 : subroutine star_remove_surface_by_mass_fraction_q(id, q, ierr)
2625 0 : use remove_shells, only: do_remove_surface_by_q
2626 : integer, intent(in) :: id
2627 : real(dp), intent(in) :: q
2628 : integer, intent(out) :: ierr
2629 0 : call do_remove_surface_by_q(id, q, ierr)
2630 0 : end subroutine star_remove_surface_by_mass_fraction_q
2631 :
2632 :
2633 0 : subroutine star_remove_surface_by_mass_gm(id, m, ierr)
2634 0 : use remove_shells, only: do_remove_surface_by_mass_gm
2635 : integer, intent(in) :: id
2636 : real(dp), intent(in) :: m
2637 : integer, intent(out) :: ierr
2638 0 : call do_remove_surface_by_mass_gm(id, m, ierr)
2639 0 : end subroutine star_remove_surface_by_mass_gm
2640 :
2641 :
2642 0 : subroutine star_limit_center_logP(id, logP_limit, ierr)
2643 0 : use remove_shells, only: do_limit_center_logP
2644 : integer, intent(in) :: id
2645 : real(dp), intent(in) :: logP_limit
2646 : integer, intent(out) :: ierr
2647 0 : call do_limit_center_logP(id, logP_limit, ierr)
2648 0 : end subroutine star_limit_center_logP
2649 :
2650 :
2651 0 : subroutine star_remove_center_by_logRho(id, logRho_limit, ierr)
2652 0 : use remove_shells, only: do_remove_center_by_logRho
2653 : integer, intent(in) :: id
2654 : real(dp), intent(in) :: logRho_limit
2655 : integer, intent(out) :: ierr
2656 0 : call do_remove_center_by_logRho(id, logRho_limit, ierr)
2657 0 : end subroutine star_remove_center_by_logRho
2658 :
2659 :
2660 0 : subroutine star_remove_fallback(id, ierr)
2661 0 : use remove_shells, only: do_remove_fallback
2662 : integer, intent(in) :: id
2663 : integer, intent(out) :: ierr
2664 0 : call do_remove_fallback(id, ierr)
2665 0 : end subroutine star_remove_fallback
2666 :
2667 :
2668 0 : subroutine smooth_abundances_in_section(id, cnt, nzlo, nzhi, ierr)
2669 : ! purely for cosmetic purposes. doesn't even try to conserve abundances.
2670 0 : use star_utils, only: smooth_abundances
2671 : integer, intent(in) :: id
2672 : integer, intent(in) :: cnt ! make this many passes
2673 : integer, intent(in) :: nzlo, nzhi ! only smooth zones nzlo to nzhi inclusive
2674 : integer, intent(out) :: ierr
2675 : type (star_info), pointer :: s
2676 0 : call star_ptr(id, s, ierr)
2677 0 : if (ierr /= 0) return
2678 0 : call smooth_abundances(s, cnt, nzlo, nzhi, ierr)
2679 0 : end subroutine smooth_abundances_in_section
2680 :
2681 :
2682 0 : subroutine smooth_xa_by_boxcar_mass( &
2683 : id, min_mass, max_mass, boxcar_mass, number_iterations, ierr)
2684 : ! conserves total mass by species
2685 0 : use star_utils, only: do_boxcar_mixing
2686 : integer, intent(in) :: id
2687 : real(dp), intent(in) :: max_mass, min_mass, boxcar_mass ! Msun
2688 : integer, intent(in) :: number_iterations
2689 : integer, intent(out) :: ierr
2690 : type (star_info), pointer :: s
2691 0 : call star_ptr(id, s, ierr)
2692 0 : if (ierr /= 0) return
2693 : call do_boxcar_mixing( &
2694 0 : s, min_mass, max_mass, boxcar_mass, number_iterations, ierr)
2695 0 : end subroutine smooth_xa_by_boxcar_mass
2696 :
2697 :
2698 0 : subroutine smooth_values_by_mass( &
2699 : id, boxcar_mass, number_iterations, val, ierr)
2700 : ! conserves total amount
2701 0 : use mix_info, only: do_smoothing_by_mass
2702 : integer, intent(in) :: id
2703 : real(dp), intent(in) :: boxcar_mass
2704 : integer, intent(in) :: number_iterations
2705 : real(dp), pointer :: val(:)
2706 : integer, intent(out) :: ierr
2707 : type (star_info), pointer :: s
2708 0 : call star_ptr(id, s, ierr)
2709 0 : if (ierr /= 0) return
2710 : call do_smoothing_by_mass( &
2711 0 : s, boxcar_mass, number_iterations, val, ierr)
2712 0 : end subroutine smooth_values_by_mass
2713 :
2714 :
2715 : ! PGSTAR interface
2716 1 : subroutine start_new_run_for_pgstar(s, ierr) ! reset logs
2717 0 : use pgstar
2718 : type (star_info), pointer :: s
2719 : integer, intent(out) :: ierr
2720 1 : call do_start_new_run_for_pgstar(s, ierr)
2721 1 : end subroutine start_new_run_for_pgstar
2722 :
2723 :
2724 0 : subroutine restart_run_for_pgstar(s, ierr)
2725 1 : use pgstar
2726 : type (star_info), pointer :: s
2727 : integer, intent(out) :: ierr
2728 0 : call do_restart_run_for_pgstar(s, ierr)
2729 0 : end subroutine restart_run_for_pgstar
2730 :
2731 :
2732 0 : subroutine read_pgstar_controls(s, ierr)
2733 0 : use pgstar, only: do_read_pgstar_controls
2734 : type (star_info), pointer :: s
2735 : integer, intent(out) :: ierr
2736 0 : call do_read_pgstar_controls(s, 'inlist', ierr)
2737 0 : end subroutine read_pgstar_controls
2738 :
2739 :
2740 0 : subroutine read_pgstar_inlist(s, inlist_fname, ierr)
2741 0 : use pgstar, only: do_read_pgstar_controls
2742 : type (star_info), pointer :: s
2743 : character(*), intent(in) :: inlist_fname
2744 : integer, intent(out) :: ierr
2745 0 : call do_read_pgstar_controls(s, inlist_fname, ierr)
2746 0 : end subroutine read_pgstar_inlist
2747 :
2748 :
2749 0 : subroutine update_pgstar_plots( &
2750 : s, must_write_files, &
2751 : ierr)
2752 0 : use pgstar
2753 : type (star_info), pointer :: s
2754 : logical, intent(in) :: must_write_files
2755 : integer, intent(out) :: ierr
2756 : call do_pgstar_plots( &
2757 : s, must_write_files, &
2758 0 : ierr)
2759 0 : end subroutine update_pgstar_plots
2760 :
2761 :
2762 0 : subroutine create_pgstar_file_name(s, dir, prefix, name)
2763 0 : use pgstar, only: do_create_file_name
2764 : type (star_info), pointer :: s
2765 : character (len=*), intent(in) :: dir, prefix
2766 : character (len=*), intent(out) :: name
2767 0 : call do_create_file_name(s, dir, prefix, name)
2768 0 : end subroutine create_pgstar_file_name
2769 :
2770 :
2771 0 : subroutine pgstar_write_plot_to_file(s, p, filename, ierr)
2772 0 : use star_pgstar, only: pgstar_win_file_data
2773 : use pgstar, only: do_write_plot_to_file
2774 : type (star_info), pointer :: s
2775 : type (pgstar_win_file_data), pointer :: p
2776 : character (len=*), intent(in) :: filename
2777 : integer, intent(out) :: ierr
2778 0 : call do_write_plot_to_file(s, p, filename, ierr)
2779 0 : end subroutine pgstar_write_plot_to_file
2780 :
2781 :
2782 0 : subroutine set_pgstar_xaxis_bounds( &
2783 : s, xaxis_by, win_xmin_in, win_xmax_in, xmargin, &
2784 : xvec, xmin, xmax, xleft, xright, dx, &
2785 : grid_min, grid_max, npts, ierr)
2786 0 : use pgstar, only: do_set_xaxis_bounds
2787 : type (star_info), pointer :: s
2788 : character (len=*), intent(in) :: xaxis_by
2789 : real, intent(in) :: win_xmin_in, win_xmax_in, xmargin
2790 : real, allocatable, dimension(:) :: xvec
2791 : real, intent(out) :: xmin, xmax, xleft, xright, dx
2792 : integer, intent(out) :: grid_min, grid_max, npts
2793 : integer, intent(out) :: ierr
2794 : call do_set_xaxis_bounds( &
2795 : s, xaxis_by, win_xmin_in, win_xmax_in, xmargin, &
2796 : xvec, xmin, xmax, xleft, xright, dx, &
2797 0 : grid_min, grid_max, npts, ierr)
2798 0 : end subroutine set_pgstar_xaxis_bounds
2799 :
2800 :
2801 0 : subroutine show_pgstar_xaxis_by(s,by,ierr)
2802 0 : use pgstar, only: do_show_xaxis_by
2803 : type (star_info), pointer :: s
2804 : character (len=*), intent(in) :: by
2805 : integer, intent(out) :: ierr
2806 0 : call do_show_xaxis_by(s,by,ierr)
2807 0 : end subroutine show_pgstar_xaxis_by
2808 :
2809 :
2810 0 : subroutine show_pgstar_annotations( &
2811 : s, show_annotation1, show_annotation2, show_annotation3)
2812 0 : use pgstar, only: do_show_pgstar_annotations
2813 : type (star_info), pointer :: s
2814 : logical, intent(in) :: &
2815 : show_annotation1, show_annotation2, show_annotation3
2816 : call do_show_pgstar_annotations( &
2817 0 : s, show_annotation1, show_annotation2, show_annotation3)
2818 0 : end subroutine show_pgstar_annotations
2819 :
2820 :
2821 0 : subroutine pgstar_show_box(s, str1, str2)
2822 0 : use pgstar, only: show_box_pgstar
2823 : type (star_info), pointer :: s
2824 : character (len=*), intent(in) :: str1, str2
2825 0 : call show_box_pgstar(s, str1, str2)
2826 0 : end subroutine pgstar_show_box
2827 :
2828 :
2829 0 : subroutine pgstar_show_title(s, title, pad)
2830 0 : use pgstar, only: show_title_pgstar
2831 : type (star_info), pointer :: s
2832 : character (len=*), intent(in) :: title
2833 : real, intent(in) :: pad
2834 : optional pad
2835 : real :: pad_arg
2836 0 : pad_arg = 0
2837 0 : if (present(pad)) pad_arg = pad
2838 0 : call show_title_pgstar(s, title, pad_arg)
2839 0 : end subroutine pgstar_show_title
2840 :
2841 :
2842 0 : subroutine pgstar_show_xaxis_label(s, label, pad)
2843 0 : use pgstar, only: show_xaxis_label_pgstar
2844 : type (star_info), pointer :: s
2845 : character (len=*), intent(in) :: label
2846 : real, intent(in) :: pad
2847 : optional pad
2848 : real :: pad_arg
2849 0 : pad_arg = 0
2850 0 : if (present(pad)) pad_arg = pad
2851 0 : call show_xaxis_label_pgstar(s, label, pad_arg)
2852 0 : end subroutine pgstar_show_xaxis_label
2853 :
2854 :
2855 0 : subroutine pgstar_show_left_yaxis_label(s, label, pad)
2856 0 : use pgstar, only: show_left_yaxis_label_pgstar
2857 : type (star_info), pointer :: s
2858 : character (len=*), intent(in) :: label
2859 : real, intent(in) :: pad
2860 : optional pad
2861 : real :: pad_arg
2862 0 : pad_arg = 0
2863 0 : if (present(pad)) pad_arg = pad
2864 0 : call show_left_yaxis_label_pgstar(s, label, pad_arg)
2865 0 : end subroutine pgstar_show_left_yaxis_label
2866 :
2867 :
2868 0 : subroutine pgstar_show_right_yaxis_label(s, label, pad)
2869 0 : use pgstar, only: show_right_yaxis_label_pgstar
2870 : type (star_info), pointer :: s
2871 : character (len=*), intent(in) :: label
2872 : real, intent(in) :: pad
2873 : optional pad
2874 : real :: pad_arg
2875 0 : pad_arg = 0
2876 0 : if (present(pad)) pad_arg = pad
2877 0 : call show_right_yaxis_label_pgstar(s, label, pad_arg)
2878 0 : end subroutine pgstar_show_right_yaxis_label
2879 :
2880 :
2881 0 : subroutine pgstar_show_left_axis_label_pgmtxt( &
2882 : s, coord, fjust, label, pad)
2883 0 : use pgstar, only: show_left_yaxis_label_pgmtxt_pgstar
2884 : type (star_info), pointer :: s
2885 : character (len=*), intent(in) :: label
2886 : real, intent(in) :: pad, coord, fjust
2887 : optional pad
2888 : real :: pad_arg
2889 0 : pad_arg = 0
2890 : if (present(pad)) pad_arg = pad
2891 : call show_left_yaxis_label_pgmtxt_pgstar( &
2892 0 : s, coord, fjust, label, pad)
2893 0 : end subroutine pgstar_show_left_axis_label_pgmtxt
2894 :
2895 :
2896 0 : subroutine pgstar_show_right_axis_label_pgmtxt( &
2897 : s, coord, fjust, label, pad)
2898 0 : use pgstar, only: show_right_yaxis_label_pgmtxt_pgstar
2899 : type (star_info), pointer :: s
2900 : character (len=*), intent(in) :: label
2901 : real, intent(in) :: pad, coord, fjust
2902 : optional pad
2903 : real :: pad_arg
2904 0 : pad_arg = 0
2905 : if (present(pad)) pad_arg = pad
2906 : call show_right_yaxis_label_pgmtxt_pgstar( &
2907 0 : s, coord, fjust, label, pad)
2908 0 : end subroutine pgstar_show_right_axis_label_pgmtxt
2909 :
2910 :
2911 0 : subroutine pgstar_show_model_number(s)
2912 0 : use pgstar, only: show_model_number_pgstar
2913 : type (star_info), pointer :: s
2914 0 : call show_model_number_pgstar(s)
2915 0 : end subroutine pgstar_show_model_number
2916 :
2917 :
2918 0 : subroutine pgstar_show_age(s)
2919 0 : use pgstar, only: show_age_pgstar
2920 : type (star_info), pointer :: s
2921 0 : call show_age_pgstar(s)
2922 0 : end subroutine pgstar_show_age
2923 :
2924 :
2925 0 : subroutine star_history_specs(s, num, names, specs, report)
2926 0 : use history, only: get_history_specs
2927 : type (star_info), pointer :: s
2928 : integer, intent(in) :: num
2929 : character (len=*), intent(in) :: names(:)
2930 : integer, intent(out) :: specs(:)
2931 : logical, intent(in) :: report
2932 0 : call get_history_specs(s, num, names, specs, report)
2933 0 : end subroutine star_history_specs
2934 :
2935 :
2936 0 : subroutine star_history_values(s, num, specs, &
2937 0 : is_int_value, int_values, values, failed_to_find_value)
2938 0 : use history, only: get_history_values
2939 : type (star_info), pointer :: s
2940 : integer, intent(in) :: num
2941 : integer, intent(in) :: specs(:)
2942 : logical, intent(out) :: is_int_value(:)
2943 : integer, intent(out) :: int_values(:)
2944 : real(dp), intent(inout) :: values(:)
2945 : logical, intent(out) :: failed_to_find_value(:)
2946 : call get_history_values(s, num, specs, &
2947 0 : is_int_value, int_values, values, failed_to_find_value)
2948 0 : end subroutine star_history_values
2949 :
2950 :
2951 0 : integer function star_get_profile_id(s, name)
2952 : ! If star_get_profile_id <0 then it failed to find the column
2953 0 : use profile_getval, only: get_profile_id
2954 : type (star_info), pointer :: s
2955 : character(len=*),intent(in) :: name
2956 0 : star_get_profile_id = get_profile_id(s,name)
2957 0 : end function star_get_profile_id
2958 :
2959 :
2960 0 : real(dp) function star_get_profile_val(s,id,k)
2961 0 : use profile, only: get_profile_val
2962 : type (star_info), pointer :: s
2963 : integer,intent(in) :: id,k
2964 0 : star_get_profile_val = get_profile_val(s,id,k)
2965 0 : end function star_get_profile_val
2966 :
2967 :
2968 0 : real(dp) function star_get_profile_output(s, name, k, ierr)
2969 0 : use profile, only : get_profile_val
2970 : type (star_info), pointer :: s
2971 : character(len=*),intent(in) :: name
2972 : integer,intent(in) :: k
2973 : integer, intent(out), optional :: ierr
2974 : integer :: id
2975 0 : if (present(ierr)) ierr = 0
2976 0 : star_get_profile_output = -HUGE(star_get_profile_output)
2977 0 : id = star_get_profile_id(s, name)
2978 0 : if (id < 0) then
2979 0 : if (present(ierr)) ierr = 1
2980 0 : return
2981 : end if
2982 0 : star_get_profile_output = get_profile_val(s,id,k)
2983 0 : end function star_get_profile_output
2984 :
2985 0 : real(dp) function star_get_profile_output_by_id(id, name, k, ierr_opt)
2986 : integer, intent(in) :: id
2987 : type (star_info), pointer :: s
2988 : character(len=*),intent(in) :: name
2989 : integer,intent(in) :: k
2990 : integer, intent(out), optional :: ierr_opt
2991 : integer :: ierr
2992 0 : star_get_profile_output_by_id = -HUGE(star_get_profile_output_by_id)
2993 0 : call star_ptr(id, s, ierr)
2994 0 : if (present(ierr_opt)) ierr_opt = ierr
2995 0 : if (ierr /= 0) return
2996 0 : star_get_profile_output_by_id = star_get_profile_output(s, name, k, ierr)
2997 0 : if (present(ierr_opt)) ierr_opt = ierr
2998 0 : end function star_get_profile_output_by_id
2999 :
3000 :
3001 0 : logical function star_get1_history_value(s, name, val)
3002 : use history, only: get1_hist_value
3003 : type (star_info), pointer :: s
3004 : character (len=*) :: name
3005 : real(dp), intent(out) :: val
3006 0 : star_get1_history_value = get1_hist_value(s, name, val)
3007 0 : end function star_get1_history_value
3008 :
3009 :
3010 0 : real(dp) function star_get_history_output(s, name, ierr)
3011 : ! If error return -huge(double) and ierr = 1, if provided
3012 0 : use history, only: get_history_specs, get_history_values, get1_hist_value
3013 : type (star_info), pointer :: s
3014 : character(len=*), intent(in) :: name
3015 : integer, intent(out), optional :: ierr
3016 : integer, parameter :: num_rows = 1
3017 0 : real(dp) :: values(num_rows)
3018 : integer :: int_values(num_rows), specs(num_rows)
3019 : logical :: is_int_value(num_rows)
3020 : logical :: failed_to_find_value(num_rows)
3021 0 : if (present(ierr)) ierr = 0
3022 0 : call get_history_specs(s, num_rows, [name], specs, .false.)
3023 : call get_history_values( &
3024 : s, num_rows, specs, &
3025 0 : is_int_value, int_values, values, failed_to_find_value)
3026 0 : if (failed_to_find_value(num_rows)) then
3027 0 : if (.not. get1_hist_value(s, name, values(num_rows))) then
3028 0 : star_get_history_output = -HUGE(star_get_history_output)
3029 0 : if (present(ierr)) ierr = 1
3030 0 : return
3031 : end if
3032 : end if
3033 0 : if (is_int_value(1)) then
3034 0 : star_get_history_output=dble(int_values(num_rows))
3035 : else
3036 0 : star_get_history_output=values(num_rows)
3037 : end if
3038 0 : end function star_get_history_output
3039 :
3040 0 : real(dp) function star_get_history_output_by_id(id, name, ierr_opt)
3041 : integer, intent(in) :: id
3042 : character(len=*),intent(in) :: name
3043 : type(star_info), pointer :: s
3044 : integer, intent(out), optional :: ierr_opt
3045 : integer :: ierr
3046 0 : star_get_history_output_by_id = -HUGE(star_get_history_output_by_id)
3047 0 : call star_ptr(id, s, ierr)
3048 0 : if (present(ierr_opt)) ierr_opt = ierr
3049 0 : if (ierr /= 0) return
3050 0 : star_get_history_output_by_id = star_get_history_output(s, name, ierr)
3051 0 : if (present(ierr_opt)) ierr_opt = ierr
3052 0 : end function star_get_history_output_by_id
3053 :
3054 :
3055 0 : subroutine star_set_mlt_vars(id, nzlo, nzhi, ierr)
3056 : use turb_info, only: set_mlt_vars
3057 : use star_def
3058 : integer, intent(in) :: id ! id for star
3059 : integer, intent(in) :: nzlo, nzhi ! range of cell numbers
3060 : integer, intent(inout) :: ierr
3061 : type (star_info), pointer :: s
3062 0 : call star_ptr(id, s, ierr)
3063 0 : if (ierr /= 0) return
3064 0 : call set_mlt_vars(s, nzlo, nzhi, ierr)
3065 0 : end subroutine star_set_mlt_vars
3066 :
3067 :
3068 0 : subroutine star_mlt_gradT(id, MLT_option, & ! can be useful when creating models
3069 : r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height, &
3070 : iso, XH1, cgrav, m, gradL_composition_term, mixing_length_alpha, &
3071 : mixing_type, gradT, Y_face, conv_vel, D, Gamma, ierr)
3072 0 : use const_def, only: dp
3073 : use turb_support, only: get_gradT
3074 : integer, intent(in) :: id
3075 : character (len=*), intent(in) :: MLT_option
3076 : real(dp), intent(in) :: &
3077 : r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height, &
3078 : XH1, cgrav, m, gradL_composition_term, mixing_length_alpha
3079 : integer, intent(in) :: iso
3080 : real(dp), intent(out) :: gradT, Y_face, conv_vel, D, Gamma
3081 : integer, intent(out) :: mixing_type, ierr
3082 : type (star_info), pointer :: s
3083 0 : call star_ptr(id, s, ierr)
3084 0 : if (ierr /= 0) return
3085 : call get_gradT(s, MLT_option, &
3086 : r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height, &
3087 : iso, XH1, cgrav, m, gradL_composition_term, mixing_length_alpha, &
3088 0 : mixing_type, gradT, Y_face, conv_vel, D, Gamma, ierr)
3089 0 : end subroutine star_mlt_gradT
3090 :
3091 :
3092 0 : subroutine star_mlt_results(id, k, MLT_option, & ! NOTE: k=0 is a valid arg
3093 : r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height, &
3094 : iso, XH1, cgrav, m, gradL_composition_term, mixing_length_alpha, &
3095 : alpha_semiconvection, thermohaline_coeff, &
3096 : mixing_type, gradT, Y_face, conv_vel, D, Gamma, ierr)
3097 0 : use const_def, only: dp
3098 : use auto_diff
3099 : use turb_support, only: Get_results
3100 : integer, intent(in) :: id
3101 : integer, intent(in) :: k
3102 : character (len=*), intent(in) :: MLT_option
3103 : type(auto_diff_real_star_order1), intent(in) :: &
3104 : r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height
3105 : integer, intent(in) :: iso
3106 : real(dp), intent(in) :: &
3107 : XH1, cgrav, m, gradL_composition_term, &
3108 : mixing_length_alpha, alpha_semiconvection, thermohaline_coeff
3109 : integer, intent(out) :: mixing_type
3110 : type(auto_diff_real_star_order1), intent(out) :: &
3111 : gradT, Y_face, conv_vel, D, Gamma
3112 : integer, intent(out) :: ierr
3113 : type(auto_diff_real_star_order1) :: dV
3114 : type (star_info), pointer :: s
3115 0 : call star_ptr(id, s, ierr)
3116 0 : if (ierr /= 0) return
3117 0 : dV = 0d0 ! dV = 1/rho - 1/rho_start and we assume rho = rho_start.
3118 : call Get_results(s, k, MLT_option, &
3119 : r, L, T, P, opacity, rho, dV, chiRho, chiT, Cp, gradr, grada, scale_height, &
3120 : iso, XH1, cgrav, m, gradL_composition_term, mixing_length_alpha, &
3121 : alpha_semiconvection, thermohaline_coeff, &
3122 0 : mixing_type, gradT, Y_face, conv_vel, D, Gamma, ierr)
3123 0 : end subroutine star_mlt_results
3124 :
3125 :
3126 0 : subroutine star_do_garbage_collection(id, ierr)
3127 0 : use init, only: do_garbage_collection
3128 : integer, intent(in) :: id
3129 : integer, intent(inout) :: ierr
3130 : type (star_info), pointer :: s
3131 0 : call star_ptr(id, s, ierr)
3132 0 : if (ierr /= 0) return
3133 0 : call do_garbage_collection(s% job% eosDT_cache_dir, ierr)
3134 0 : if (ierr /= 0) return
3135 0 : end subroutine star_do_garbage_collection
3136 :
3137 :
3138 1 : subroutine star_shutdown_pgstar(id, ierr)
3139 0 : use pgstar, only: shutdown_pgstar
3140 : integer, intent(in) :: id ! id for star
3141 : integer, intent(out) :: ierr
3142 : type (star_info), pointer :: s
3143 : ierr = 0
3144 1 : call star_ptr(id, s, ierr)
3145 1 : if (ierr /= 0) return
3146 1 : call shutdown_pgstar(s)
3147 1 : end subroutine star_shutdown_pgstar
3148 :
3149 :
3150 0 : subroutine star_create_RSP_model(id, ierr)
3151 1 : use init, only: create_RSP_model
3152 : integer, intent(in) :: id
3153 : integer, intent(out) :: ierr
3154 0 : call create_RSP_model(id, ierr)
3155 0 : end subroutine star_create_RSP_model
3156 :
3157 :
3158 0 : subroutine star_create_RSP2_model(id, ierr)
3159 0 : use init, only: create_RSP2_model
3160 : integer, intent(in) :: id
3161 : integer, intent(out) :: ierr
3162 0 : call create_RSP2_model(id, ierr)
3163 0 : end subroutine star_create_RSP2_model
3164 :
3165 :
3166 0 : subroutine star_do1_rsp_build(s,ierr)
3167 : ! call from other_rsp_build_model after changing params.
3168 : ! can change rsp_* params; but cannot change nz or net.
3169 : ! multiple calls are ok to search.
3170 0 : use rsp, only : do1_rsp_build
3171 : type (star_info), pointer :: s
3172 : integer, intent(out) :: ierr
3173 0 : call do1_rsp_build(s,ierr)
3174 0 : end subroutine star_do1_rsp_build
3175 :
3176 :
3177 0 : subroutine rsp_do1_eos_and_kap(s,k,ierr)
3178 0 : use rsp_step, only : do1_eos_and_kap
3179 : type (star_info), pointer :: s
3180 : integer, intent(in) :: k
3181 : integer, intent(out) :: ierr
3182 0 : call do1_eos_and_kap(s,s% nz+1-k,ierr)
3183 0 : end subroutine rsp_do1_eos_and_kap
3184 :
3185 :
3186 0 : integer function check_change_timestep_limit( &
3187 : id, delta_value, lim, hard_lim, i, msg, &
3188 : skip_hard_limit, dt_limit_ratio, relative_excess)
3189 0 : use const_def, only:ln10
3190 : use timestep, only: check_change
3191 : use star_def, only: terminate
3192 : integer, intent(in) :: id
3193 : real(dp), intent(in) :: delta_value, lim, hard_lim
3194 : integer, intent(in) :: i
3195 : character (len=*), intent(in) :: msg
3196 : logical, intent(in) :: skip_hard_limit
3197 : real(dp), intent(inout) :: dt_limit_ratio
3198 : real(dp), intent(out) :: relative_excess
3199 : type (star_info), pointer :: s
3200 : integer :: ierr
3201 : ierr = 0
3202 0 : call star_ptr(id, s, ierr)
3203 0 : if (ierr /= 0) then
3204 0 : check_change_timestep_limit = terminate
3205 : return
3206 : end if
3207 : check_change_timestep_limit = check_change( &
3208 : s, delta_value, lim, hard_lim, i, msg, &
3209 0 : skip_hard_limit, dt_limit_ratio, relative_excess)
3210 0 : end function check_change_timestep_limit
3211 :
3212 :
3213 0 : integer function check_change_integer_timestep_limit( &
3214 : id, limit, hard_limit, value, msg, skip_hard_limit, dt, dt_limit_ratio)
3215 0 : use const_def, only:ln10
3216 : use timestep, only: check_integer_limit
3217 : use star_def, only: terminate
3218 : integer, intent(in) :: id
3219 : integer, intent(in) :: limit, hard_limit, value
3220 : character (len=*), intent(in) :: msg
3221 : logical, intent(in) :: skip_hard_limit
3222 : real(dp), intent(in) :: dt
3223 : real(dp), intent(inout) :: dt_limit_ratio
3224 : type (star_info), pointer :: s
3225 : integer :: ierr
3226 : ierr = 0
3227 0 : call star_ptr(id, s, ierr)
3228 0 : if (ierr /= 0) then
3229 0 : check_change_integer_timestep_limit = terminate
3230 : return
3231 : end if
3232 : check_change_integer_timestep_limit = check_integer_limit( &
3233 0 : s, limit, hard_limit, value, msg, skip_hard_limit, dt, dt_limit_ratio)
3234 0 : end function check_change_integer_timestep_limit
3235 :
3236 :
3237 0 : real(dp) function star_remnant_mass(id)
3238 0 : use star_utils, only: get_remnant_mass
3239 : integer, intent(in) :: id
3240 : type (star_info), pointer :: s
3241 : integer :: ierr
3242 : ierr = 0
3243 0 : call star_ptr(id, s, ierr)
3244 0 : star_remnant_mass = get_remnant_mass(s)
3245 0 : end function star_remnant_mass
3246 :
3247 :
3248 0 : real(dp) function star_ejecta_mass(id)
3249 0 : use star_utils, only: get_ejecta_mass
3250 : integer, intent(in) :: id
3251 : type (star_info), pointer :: s
3252 : integer :: ierr
3253 : ierr = 0
3254 0 : call star_ptr(id, s, ierr)
3255 0 : star_ejecta_mass = get_ejecta_mass(s)
3256 0 : end function star_ejecta_mass
3257 :
3258 :
3259 : ! Returns the next available star id
3260 0 : integer function star_find_next_star_id()
3261 0 : use star_private_def, only : find_next_star_id
3262 0 : star_find_next_star_id = find_next_star_id()
3263 0 : end function star_find_next_star_id
3264 :
3265 :
3266 0 : subroutine star_init_star_handles()
3267 0 : use star_private_def, only: init_star_handles
3268 0 : call init_star_handles()
3269 0 : end subroutine star_init_star_handles
3270 :
3271 :
3272 0 : subroutine star_get_control_namelist(id, name, val, ierr)
3273 0 : use ctrls_io, only: get_control
3274 : integer, intent(in) :: id
3275 : character(len=*),intent(in) :: name
3276 : character(len=*),intent(out) :: val
3277 : integer, intent(out) :: ierr
3278 : type (star_info), pointer :: s
3279 :
3280 : ierr = 0
3281 0 : call star_ptr(id, s, ierr)
3282 0 : if(ierr/=0) return
3283 0 : call get_control(s, name, val, ierr)
3284 :
3285 0 : end subroutine star_get_control_namelist
3286 :
3287 0 : subroutine star_set_control_namelist(id, name, val, ierr)
3288 0 : use ctrls_io, only: set_control
3289 : integer, intent(in) :: id
3290 : character(len=*),intent(in) :: name
3291 : character(len=*),intent(in) :: val
3292 : integer, intent(out) :: ierr
3293 : type (star_info), pointer :: s
3294 :
3295 : ierr = 0
3296 0 : call star_ptr(id, s, ierr)
3297 0 : if(ierr/=0) return
3298 0 : call set_control(s, name, val, ierr)
3299 :
3300 0 : end subroutine star_set_control_namelist
3301 :
3302 :
3303 0 : subroutine star_get_star_job_namelist(id, name, val, ierr)
3304 0 : use star_job_ctrls_io, only: get_star_job
3305 : integer, intent(in) :: id
3306 : character(len=*),intent(in) :: name
3307 : character(len=*),intent(out) :: val
3308 : integer, intent(out) :: ierr
3309 : type (star_info), pointer :: s
3310 :
3311 : ierr = 0
3312 0 : call star_ptr(id, s, ierr)
3313 0 : if(ierr/=0) return
3314 0 : call get_star_job(s, name, val, ierr)
3315 :
3316 0 : end subroutine star_get_star_job_namelist
3317 :
3318 0 : subroutine star_set_star_job_namelist(id, name, val, ierr)
3319 0 : use star_job_ctrls_io, only: set_star_job
3320 : integer, intent(in) :: id
3321 : character(len=*),intent(in) :: name
3322 : character(len=*),intent(in) :: val
3323 : integer, intent(out) :: ierr
3324 : type (star_info), pointer :: s
3325 :
3326 : ierr = 0
3327 0 : call star_ptr(id, s, ierr)
3328 0 : if(ierr/=0) return
3329 0 : call set_star_job(s, name, val, ierr)
3330 :
3331 0 : end subroutine star_set_star_job_namelist
3332 :
3333 : end module star_lib
|
