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 0 : subroutine remesh_for_TDC_pulsation(id, ierr)
822 0 : use set_flags, only: set_TDC_to_RSP2_mesh
823 : integer, intent(in) :: id
824 : integer, intent(out) :: ierr
825 : type (star_info), pointer :: s
826 0 : call star_ptr(id, s, ierr)
827 0 : if (ierr /= 0) return
828 0 : call set_TDC_to_RSP2_mesh(id, ierr)
829 0 : end subroutine remesh_for_TDC_pulsation
830 :
831 0 : subroutine star_set_RSP2_flag(id, et_flag, ierr)
832 0 : use set_flags, only: set_RSP2_flag
833 : integer, intent(in) :: id
834 : logical, intent(in) :: et_flag
835 : integer, intent(out) :: ierr
836 : type (star_info), pointer :: s
837 0 : call star_ptr(id, s, ierr)
838 0 : if (ierr /= 0) return
839 0 : call set_RSP2_flag(id, et_flag, ierr)
840 0 : end subroutine star_set_RSP2_flag
841 :
842 :
843 0 : subroutine star_set_RSP_flag(id, RSP_flag, ierr)
844 0 : use set_flags, only: set_RSP_flag
845 : integer, intent(in) :: id
846 : logical, intent(in) :: RSP_flag
847 : integer, intent(out) :: ierr
848 0 : call set_RSP_flag(id, RSP_flag, ierr)
849 0 : end subroutine star_set_RSP_flag
850 :
851 :
852 0 : subroutine star_set_D_omega_flag(id, D_omega_flag, ierr)
853 0 : use set_flags, only: set_D_omega_flag
854 : integer, intent(in) :: id
855 : logical, intent(in) :: D_omega_flag
856 : integer, intent(out) :: ierr
857 0 : call set_D_omega_flag(id, D_omega_flag, ierr)
858 0 : end subroutine star_set_D_omega_flag
859 :
860 :
861 0 : subroutine star_set_am_nu_rot_flag(id, am_nu_rot_flag, ierr)
862 0 : use set_flags, only: set_am_nu_rot_flag
863 : integer, intent(in) :: id
864 : logical, intent(in) :: am_nu_rot_flag
865 : integer, intent(out) :: ierr
866 0 : call set_am_nu_rot_flag(id, am_nu_rot_flag, ierr)
867 0 : end subroutine star_set_am_nu_rot_flag
868 :
869 :
870 : ! this routine is for adding or removing velocity variables.
871 : ! simply adds or removes; doesn't reconverge the model.
872 0 : subroutine star_set_v_flag(id, v_flag, ierr)
873 0 : use set_flags, only: set_v_flag
874 : integer, intent(in) :: id
875 : logical, intent(in) :: v_flag
876 : integer, intent(out) :: ierr
877 0 : call set_v_flag(id, v_flag, ierr)
878 0 : end subroutine star_set_v_flag
879 :
880 :
881 : ! this routine is for adding or removing velocity variables.
882 : ! simply adds or removes; doesn't reconverge the model.
883 0 : subroutine star_set_u_flag(id, u_flag, ierr)
884 0 : use set_flags, only: set_u_flag
885 : integer, intent(in) :: id
886 : logical, intent(in) :: u_flag
887 : integer, intent(out) :: ierr
888 0 : call set_u_flag(id, u_flag, ierr)
889 0 : end subroutine star_set_u_flag
890 :
891 :
892 : ! this routine is for adding or removing rotation variables.
893 : ! simply adds or removes; doesn't reconverge the model.
894 0 : subroutine star_set_rotation_flag(id, rotation_flag, ierr)
895 0 : use set_flags, only: set_rotation_flag
896 : use hydro_rotation, only: set_rotation_info
897 : integer, intent(in) :: id
898 : logical, intent(in) :: rotation_flag
899 : integer, intent(out) :: ierr
900 : logical :: previous_rotation_flag
901 : type (star_info), pointer :: s
902 0 : call star_ptr(id, s, ierr)
903 0 : if (ierr /= 0) then
904 0 : write(*,*) "Failed in star_ptr at star_set_rotation_flag"
905 : return
906 : end if
907 0 : previous_rotation_flag = s% rotation_flag
908 :
909 0 : call set_rotation_flag(id, rotation_flag, ierr)
910 :
911 0 : if (rotation_flag .and. .not. previous_rotation_flag) then
912 0 : call set_rotation_info(s, .false., ierr)
913 : end if
914 0 : end subroutine star_set_rotation_flag
915 :
916 :
917 : ! you can change the nuclear net at the start or between steps
918 : ! added species are given initial abundances based on solar scaled by initial_z
919 :
920 0 : subroutine star_change_to_new_net( &
921 : id, adjust_abundances_for_new_isos, new_net_name, ierr)
922 0 : use adjust_xyz, only: change_net
923 : integer, intent(in) :: id
924 : logical, intent(in) :: adjust_abundances_for_new_isos
925 : character (len=*), intent(in) :: new_net_name
926 : integer, intent(out) :: ierr
927 : call change_net( &
928 0 : id, adjust_abundances_for_new_isos, new_net_name, ierr)
929 0 : end subroutine star_change_to_new_net
930 :
931 :
932 0 : subroutine star_change_to_new_small_net( &
933 : id, adjust_abundances_for_new_isos, new_small_net_name, ierr)
934 0 : use adjust_xyz, only: change_small_net
935 : integer, intent(in) :: id
936 : logical, intent(in) :: adjust_abundances_for_new_isos
937 : character (len=*), intent(in) :: new_small_net_name
938 : integer, intent(out) :: ierr
939 : call change_small_net( &
940 0 : id, adjust_abundances_for_new_isos, new_small_net_name, ierr)
941 0 : end subroutine star_change_to_new_small_net
942 :
943 :
944 : ! Heger-style adaptive network (Woosley, Heger, et al, ApJSS, 151:75-102, 2004)
945 0 : subroutine star_adjust_net(id, &
946 : min_x_for_keep, min_x_for_n, min_x_for_add, max_Z, max_N, max_A, ierr)
947 0 : use adjust_net, only: check_adjust_net
948 : integer, intent(in) :: id
949 : real(dp), intent(in) :: &
950 : min_x_for_keep, min_x_for_n, min_x_for_add, max_Z, max_N, max_A
951 : integer, intent(out) :: ierr
952 : type (star_info), pointer :: s
953 0 : call star_ptr(id, s, ierr)
954 0 : if (ierr /= 0) return
955 : call check_adjust_net(s, s% species, &
956 : min_x_for_keep, min_x_for_n, min_x_for_add, &
957 0 : max_Z, max_N, max_A, ierr)
958 0 : end subroutine star_adjust_net
959 :
960 :
961 0 : logical function is_included_in_net(id, species, ierr)
962 : integer, intent(in) :: id
963 : integer, intent(in) :: species ! a chem_id such as ihe3. see chem_def.
964 : integer, intent(out) :: ierr
965 : type (star_info), pointer :: s
966 0 : call star_ptr(id, s, ierr)
967 0 : if (ierr /= 0) then
968 0 : is_included_in_net = .false.
969 : return
970 : end if
971 0 : is_included_in_net = (s% net_iso(species) /= 0)
972 0 : end function is_included_in_net
973 :
974 :
975 : ! here are some routines for doing special adjustments to the star's composition
976 :
977 :
978 : ! set uniform composition with one of the standard metal z fractions from chem_def
979 0 : subroutine star_set_standard_composition(id, h1, h2, he3, he4, &
980 : which_zfracs, dump_missing_metals_into_heaviest, ierr)
981 : use adjust_xyz, only: set_standard_composition
982 : integer, intent(in) :: id
983 : real(dp), intent(in) :: h1, h2, he3, he4 ! mass fractions
984 : integer, intent(in) :: which_zfracs ! defined in chem_def. e.g., GS98_zfracs
985 : logical, intent(in) :: dump_missing_metals_into_heaviest
986 : integer, intent(out) :: ierr
987 : type (star_info), pointer :: s
988 0 : call star_ptr(id, s, ierr)
989 0 : if (ierr /= 0) return
990 : call set_standard_composition(s, s% species, h1, h2, he3, he4, &
991 0 : which_zfracs, dump_missing_metals_into_heaviest, ierr)
992 0 : end subroutine star_set_standard_composition
993 :
994 :
995 0 : subroutine star_uniform_xa_from_file(id, file_for_uniform_xa, ierr)
996 0 : use adjust_xyz, only: set_uniform_xa_from_file
997 : integer, intent(in) :: id
998 : character (len=*), intent(in) :: file_for_uniform_xa
999 : integer, intent(out) :: ierr
1000 0 : call set_uniform_xa_from_file(id, file_for_uniform_xa, ierr)
1001 0 : end subroutine star_uniform_xa_from_file
1002 :
1003 :
1004 0 : subroutine star_set_uniform_composition(id, species, xa, ierr)
1005 0 : use adjust_xyz, only: set_uniform_composition
1006 : integer, intent(in) :: id
1007 : integer, intent(in) :: species
1008 : real(dp), intent(in) :: xa(species)
1009 : integer, intent(out) :: ierr
1010 0 : call set_uniform_composition(id, species, xa, ierr)
1011 0 : end subroutine star_set_uniform_composition
1012 :
1013 :
1014 0 : subroutine star_set_composition(id, species, xa, ierr)
1015 0 : use adjust_xyz, only: set_composition
1016 : integer, intent(in) :: id
1017 : integer, intent(in) :: species
1018 : real(dp), intent(in) :: xa(species) ! the replacement mass fractions
1019 : integer, intent(out) :: ierr
1020 : type (star_info), pointer :: s
1021 0 : call star_ptr(id, s, ierr)
1022 0 : if (ierr /= 0) return
1023 0 : call set_composition(id, 1, s% nz, species, xa, ierr)
1024 0 : end subroutine star_set_composition
1025 :
1026 :
1027 0 : subroutine set_composition_in_section(id, nzlo, nzhi, species, xa, ierr)
1028 0 : use adjust_xyz, only: set_composition
1029 : integer, intent(in) :: id
1030 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1031 : integer, intent(in) :: species
1032 : real(dp), intent(in) :: xa(species) ! cells from nzlo to nzhi get this composition.
1033 : integer, intent(out) :: ierr
1034 0 : call set_composition(id, nzlo, nzhi, species, xa, ierr)
1035 0 : end subroutine set_composition_in_section
1036 :
1037 :
1038 0 : subroutine change_to_xa_for_accretion(id, nzlo, nzhi, ierr)
1039 0 : use adjust_xyz, only: do_change_to_xa_for_accretion
1040 : integer, intent(in) :: id
1041 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1042 : integer, intent(out) :: ierr
1043 0 : call do_change_to_xa_for_accretion(id, nzlo, nzhi, ierr)
1044 0 : end subroutine change_to_xa_for_accretion
1045 :
1046 :
1047 0 : subroutine star_set_abundance_ratio(id, i1, i2, ratio, ierr)
1048 0 : use adjust_xyz, only: set_abundance_ratio
1049 : integer, intent(in) :: id
1050 : integer, intent(in) :: i1, i2 ! chem id's such as ih1 or ihe4 from chem_def
1051 : real(dp), intent(in) :: ratio ! change abundances of i1 and i2 s.t. x(i1)/x(i2)=ratio
1052 : integer, intent(out) :: ierr
1053 : type (star_info), pointer :: s
1054 0 : call star_ptr(id, s, ierr)
1055 0 : if (ierr /= 0) return
1056 0 : call set_abundance_ratio(id, i1, i2, ratio, 1, s% nz, ierr)
1057 0 : end subroutine star_set_abundance_ratio
1058 :
1059 :
1060 0 : subroutine set_abundance_ratio_in_section(id, i1, i2, ratio, nzlo, nzhi, ierr)
1061 0 : use adjust_xyz, only: set_abundance_ratio
1062 : integer, intent(in) :: id
1063 : integer, intent(in) :: i1, i2 ! chem id's such as ih1 or ihe4 from chem_def
1064 : real(dp), intent(in) :: ratio ! change abundances of i1 and i2 s.t. x(i1)/x(i2)=ratio
1065 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1066 : integer, intent(out) :: ierr
1067 0 : call set_abundance_ratio(id, i1, i2, ratio, nzlo, nzhi, ierr)
1068 0 : end subroutine set_abundance_ratio_in_section
1069 :
1070 :
1071 0 : subroutine star_zero_alpha_RTI(id, ierr)
1072 0 : use star_utils, only: set_zero_alpha_RTI
1073 : integer, intent(in) :: id
1074 : integer, intent(out) :: ierr
1075 0 : call set_zero_alpha_RTI(id, ierr)
1076 0 : end subroutine star_zero_alpha_RTI
1077 :
1078 :
1079 0 : subroutine star_set_y(id, y, ierr)
1080 : ! changes abundances of h1 and he4 only
1081 : ! adjust ratio of h1 to he4 to be (1-y-z)/y at each point
1082 0 : use adjust_xyz, only: set_y
1083 : integer, intent(in) :: id
1084 : real(dp), intent(in) :: y ! new value for average he4 mass fraction
1085 : integer, intent(out) :: ierr
1086 : type (star_info), pointer :: s
1087 0 : call star_ptr(id, s, ierr)
1088 0 : if (ierr /= 0) return
1089 0 : call set_y(s, y, 1, s% nz, ierr)
1090 0 : end subroutine star_set_y
1091 :
1092 :
1093 0 : subroutine set_y_in_section(id, y, nzlo, nzhi, ierr)
1094 : ! change abundances of h1 and he4
1095 0 : use adjust_xyz, only: set_y
1096 : integer, intent(in) :: id
1097 : real(dp), intent(in) :: y ! new value for average he4 mass fraction
1098 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1099 : integer, intent(out) :: ierr
1100 : type (star_info), pointer :: s
1101 0 : call star_ptr(id, s, ierr)
1102 0 : if (ierr /= 0) return
1103 0 : call set_y(s, y, nzlo, nzhi, ierr)
1104 0 : end subroutine set_y_in_section
1105 :
1106 :
1107 0 : subroutine star_set_z(id, new_z, ierr)
1108 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1109 : ! to make large changes in z, you'll need to spread it out over a number of steps
1110 : ! in order to let the model adjust to the changes a small amount at a time.
1111 0 : use adjust_xyz, only: set_z
1112 : integer, intent(in) :: id
1113 : real(dp), intent(in) :: new_z
1114 : integer, intent(out) :: ierr
1115 : type (star_info), pointer :: s
1116 0 : call star_ptr(id, s, ierr)
1117 0 : if (ierr /= 0) return
1118 0 : call set_z(s, new_z, 1, s% nz, ierr)
1119 0 : end subroutine star_set_z
1120 :
1121 :
1122 0 : subroutine set_z_in_section(id, new_z, nzlo, nzhi, ierr)
1123 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1124 : ! to make large changes in z, you'll need to spread it out over a number of steps
1125 : ! in order to let the model adjust to the changes a small amount at a time.
1126 : ! BTW: the set_z routine considers everything to be a "metal" except H1 and He4.
1127 0 : use adjust_xyz, only: set_z
1128 : integer, intent(in) :: id
1129 : real(dp), intent(in) :: new_z
1130 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1131 : integer, intent(out) :: ierr
1132 : type (star_info), pointer :: s
1133 0 : call star_ptr(id, s, ierr)
1134 0 : if (ierr /= 0) return
1135 0 : call set_z(s, new_z, nzlo, nzhi, ierr)
1136 0 : end subroutine set_z_in_section
1137 :
1138 :
1139 0 : subroutine star_replace_element(id, chem1, chem2, ierr)
1140 : ! replaces chem1 by chem2.
1141 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1142 : integer, intent(in) :: id
1143 : integer, intent(in) :: chem1, chem2 ! values are chem_id's such as ihe4. see chem_def.
1144 : integer, intent(out) :: ierr
1145 : type (star_info), pointer :: s
1146 0 : call star_ptr(id, s, ierr)
1147 0 : if (ierr /= 0) return
1148 0 : call replace_element_in_section(id, chem1, chem2, 1, s% nz, ierr)
1149 0 : end subroutine star_replace_element
1150 :
1151 :
1152 0 : subroutine replace_element_in_section(id, chem1, chem2, nzlo, nzhi, ierr)
1153 : ! replaces chem1 by chem2.
1154 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1155 : use adjust_xyz, only: do_replace
1156 : integer, intent(in) :: id
1157 : integer, intent(in) :: chem1, chem2 ! values are chem_id's such as ihe4. see chem_def.
1158 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1159 : integer, intent(out) :: ierr
1160 : type (star_info), pointer :: s
1161 0 : call star_ptr(id, s, ierr)
1162 0 : if (ierr /= 0) return
1163 0 : call do_replace(s, chem1, chem2, nzlo, nzhi, ierr)
1164 0 : end subroutine replace_element_in_section
1165 :
1166 :
1167 0 : subroutine star_set_abundance(id, chem_id, new_frac, ierr)
1168 : ! set mass fraction of species to new_frac uniformly in cells nzlo to nzhi
1169 : !
1170 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1171 : integer, intent(in) :: id
1172 : integer, intent(in) :: chem_id ! a chem_id such as ihe4. see chem_def.
1173 : real(dp), intent(in) :: new_frac
1174 : integer, intent(out) :: ierr
1175 : type (star_info), pointer :: s
1176 0 : call star_ptr(id, s, ierr)
1177 0 : if (ierr /= 0) return
1178 0 : call set_abundance_in_section(id, chem_id, new_frac, 1, s% nz, ierr)
1179 0 : end subroutine star_set_abundance
1180 :
1181 :
1182 0 : subroutine set_abundance_in_section(id, chem_id, new_frac, nzlo, nzhi, ierr)
1183 : ! set mass fraction of species to new_frac uniformly in cells nzlo to nzhi
1184 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1185 : use adjust_xyz, only: do_set_abundance
1186 : integer, intent(in) :: id
1187 : integer, intent(in) :: chem_id ! a chem_id such as ihe4. see chem_def.
1188 : real(dp), intent(in) :: new_frac
1189 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1190 : integer, intent(out) :: ierr
1191 : type (star_info), pointer :: s
1192 0 : call star_ptr(id, s, ierr)
1193 0 : if (ierr /= 0) return
1194 0 : call do_set_abundance(s, chem_id, new_frac, nzlo, nzhi, ierr)
1195 0 : end subroutine set_abundance_in_section
1196 :
1197 :
1198 0 : subroutine uniform_mix_section(id, nzlo, nzhi, ierr)
1199 : ! uniformly mix abundances in cells nzlo to nzhi
1200 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1201 0 : use adjust_xyz, only: do_uniform_mix_section
1202 : integer, intent(in) :: id
1203 : integer, intent(in) :: nzlo, nzhi ! change cells from nzlo to nzhi, inclusive.
1204 : integer, intent(out) :: ierr
1205 : type (star_info), pointer :: s
1206 0 : write(*,*) 'uniform_mix_section'
1207 0 : call star_ptr(id, s, ierr)
1208 0 : if (ierr /= 0) return
1209 0 : call do_uniform_mix_section(s, s% species, nzlo, nzhi, ierr)
1210 0 : end subroutine uniform_mix_section
1211 :
1212 :
1213 0 : subroutine uniform_mix_envelope_down_to_T(id, T, ierr)
1214 : ! uniformly mix abundances in cells from surface down to given temperature
1215 : ! NOTE: this routine simply changes abundances; it doesn't reconverge the model.
1216 0 : use adjust_xyz, only: do_uniform_mix_envelope_down_to_T
1217 : integer, intent(in) :: id
1218 : real(dp), intent(in) :: T
1219 : integer, intent(out) :: ierr
1220 : type (star_info), pointer :: s
1221 0 : write(*,*) 'uniform_mix_envelope_down_to_T'
1222 0 : call star_ptr(id, s, ierr)
1223 0 : if (ierr /= 0) return
1224 0 : call do_uniform_mix_envelope_down_to_T(s, T, ierr)
1225 0 : end subroutine uniform_mix_envelope_down_to_T
1226 :
1227 :
1228 : ! access to the value of the next timestep
1229 :
1230 0 : subroutine get_dt_next(id, dt, ierr)
1231 0 : use star_private_def
1232 : integer, intent(in) :: id
1233 : real(dp) , intent(out) :: dt
1234 : integer, intent(out) :: ierr
1235 : type (star_info), pointer :: s
1236 0 : call star_ptr(id, s, ierr)
1237 0 : if (ierr /= 0) then
1238 0 : dt = -1
1239 : return
1240 : end if
1241 0 : dt = s% dt_next
1242 0 : end subroutine get_dt_next
1243 :
1244 :
1245 0 : subroutine set_dt_next(id, dt, ierr)
1246 0 : use star_private_def
1247 : integer, intent(in) :: id
1248 : real(dp), intent(in) :: dt
1249 : integer, intent(out) :: ierr
1250 : type (star_info), pointer :: s
1251 0 : call star_ptr(id, s, ierr)
1252 0 : if (ierr /= 0) return
1253 0 : s% dt_next = dt
1254 0 : end subroutine set_dt_next
1255 :
1256 :
1257 : ! relaxation routines (for "pseudo-evolution" of the model)
1258 :
1259 0 : subroutine star_relax_mass(id, new_mass, lg_max_abs_mdot, ierr) ! also resets initial_mass
1260 : ! acts like accretion or wind to change star mass
1261 0 : use relax, only: do_relax_mass
1262 : integer, intent(in) :: id
1263 : real(dp), intent(in) :: new_mass ! in Msun units
1264 : real(dp), intent(in) :: lg_max_abs_mdot ! in log10(Msun/year)
1265 : ! e.g., -8.0 for mdot of -10^-8 Msun/year
1266 : integer, intent(out) :: ierr
1267 0 : call do_relax_mass(id, new_mass, lg_max_abs_mdot, ierr)
1268 0 : end subroutine star_relax_mass
1269 :
1270 :
1271 0 : subroutine star_relax_mass_to_remove_H_env( &
1272 : id, extra_mass, lg_max_abs_mdot, ierr) ! also resets initial_mass
1273 0 : use relax, only: do_relax_mass
1274 : use report, only: get_mass_info
1275 : integer, intent(in) :: id
1276 : real(dp), intent(in) :: extra_mass
1277 : real(dp), intent(in) :: lg_max_abs_mdot ! in log10(Msun/year)
1278 : ! e.g., -8.0 for mdot of -10^-8 Msun/year
1279 : integer, intent(out) :: ierr
1280 : type (star_info), pointer :: s
1281 : ierr = 0
1282 0 : call star_ptr(id, s, ierr)
1283 0 : if (ierr /= 0) return
1284 0 : call get_mass_info(s, s% dm, ierr)
1285 0 : if (ierr /= 0) return
1286 0 : call do_relax_mass(id, s% he_core_mass + extra_mass, lg_max_abs_mdot, ierr)
1287 0 : end subroutine star_relax_mass_to_remove_H_env
1288 :
1289 :
1290 0 : subroutine star_relax_mass_scale( &
1291 : id, new_mass, dlgm_per_step, change_mass_years_for_dt, ierr) ! also resets initial_mass
1292 : ! rescales star mass without changing composition as function of m/mstar
1293 0 : use relax, only: do_relax_mass_scale
1294 : integer, intent(in) :: id
1295 : real(dp), intent(in) :: new_mass ! in Msun units
1296 : real(dp), intent(in) :: dlgm_per_step, change_mass_years_for_dt
1297 : integer, intent(out) :: ierr
1298 : call do_relax_mass_scale( &
1299 0 : id, new_mass, dlgm_per_step, change_mass_years_for_dt, ierr)
1300 0 : end subroutine star_relax_mass_scale
1301 :
1302 :
1303 0 : subroutine star_relax_core( &
1304 : id, new_core_mass, dlg_core_mass_per_step, &
1305 : relax_core_years_for_dt, core_avg_rho, core_avg_eps, ierr)
1306 0 : use relax, only: do_relax_core
1307 : integer, intent(in) :: id
1308 : real(dp), intent(in) :: new_core_mass ! in Msun units
1309 : real(dp), intent(in) :: dlg_core_mass_per_step, relax_core_years_for_dt
1310 : real(dp), intent(in) :: core_avg_rho, core_avg_eps
1311 : ! adjust R_center according to core_avg_rho (g cm^-3)
1312 : ! adjust L_center according to core_avg_eps (erg g^-1 s^-1)
1313 : integer, intent(out) :: ierr
1314 : call do_relax_core( &
1315 : id, new_core_mass, dlg_core_mass_per_step, &
1316 0 : relax_core_years_for_dt, core_avg_rho, core_avg_eps, ierr)
1317 0 : end subroutine star_relax_core
1318 :
1319 :
1320 0 : subroutine star_relax_M_center( &
1321 : id, new_mass, dlgm_per_step, relax_M_center_dt, ierr)
1322 0 : use relax, only: do_relax_M_center
1323 : integer, intent(in) :: id
1324 : real(dp), intent(in) :: new_mass ! in Msun units
1325 : real(dp), intent(in) :: dlgm_per_step, relax_M_center_dt
1326 : integer, intent(out) :: ierr
1327 : call do_relax_M_center( &
1328 0 : id, new_mass, dlgm_per_step, relax_M_center_dt, ierr)
1329 0 : end subroutine star_relax_M_center
1330 :
1331 :
1332 0 : subroutine star_relax_R_center( &
1333 : id, new_R_center, dlgR_per_step, relax_R_center_dt, ierr)
1334 0 : use relax, only: do_relax_R_center
1335 : integer, intent(in) :: id
1336 : real(dp), intent(in) :: new_R_center ! in cm
1337 : real(dp), intent(in) :: dlgR_per_step, relax_R_center_dt
1338 : integer, intent(out) :: ierr
1339 : call do_relax_R_center( &
1340 0 : id, new_R_center, dlgR_per_step, relax_R_center_dt, ierr)
1341 0 : end subroutine star_relax_R_center
1342 :
1343 :
1344 0 : subroutine star_relax_v_center( &
1345 : id, new_v_center, dv_per_step, relax_v_center_dt, ierr)
1346 0 : use relax, only: do_relax_v_center
1347 : integer, intent(in) :: id
1348 : real(dp), intent(in) :: new_v_center ! in cm/s
1349 : real(dp), intent(in) :: dv_per_step, relax_v_center_dt
1350 : integer, intent(out) :: ierr
1351 : call do_relax_v_center( &
1352 0 : id, new_v_center, dv_per_step, relax_v_center_dt, ierr)
1353 0 : end subroutine star_relax_v_center
1354 :
1355 :
1356 0 : subroutine star_relax_L_center( &
1357 : id, new_L_center, dlgL_per_step, relax_L_center_dt, ierr)
1358 0 : use relax, only: do_relax_L_center
1359 : integer, intent(in) :: id
1360 : real(dp), intent(in) :: new_L_center ! in ergs/second
1361 : real(dp), intent(in) :: dlgL_per_step, relax_L_center_dt
1362 : integer, intent(out) :: ierr
1363 : call do_relax_L_center( &
1364 0 : id, new_L_center, dlgL_per_step, relax_L_center_dt, ierr)
1365 0 : end subroutine star_relax_L_center
1366 :
1367 :
1368 0 : subroutine star_relax_dxdt_nuc_factor(id, new_value, per_step_multiplier, ierr)
1369 0 : use relax, only: do_relax_dxdt_nuc_factor
1370 : integer, intent(in) :: id
1371 : real(dp), intent(in) :: new_value
1372 : real(dp), intent(in) :: per_step_multiplier
1373 : integer, intent(out) :: ierr
1374 0 : call do_relax_dxdt_nuc_factor(id, new_value, per_step_multiplier, ierr)
1375 0 : end subroutine star_relax_dxdt_nuc_factor
1376 :
1377 :
1378 0 : subroutine star_relax_eps_nuc_factor(id, new_value, per_step_multiplier, ierr)
1379 0 : use relax, only: do_relax_eps_nuc_factor
1380 : integer, intent(in) :: id
1381 : real(dp), intent(in) :: new_value
1382 : real(dp), intent(in) :: per_step_multiplier
1383 : integer, intent(out) :: ierr
1384 0 : call do_relax_eps_nuc_factor(id, new_value, per_step_multiplier, ierr)
1385 0 : end subroutine star_relax_eps_nuc_factor
1386 :
1387 :
1388 0 : subroutine star_relax_opacity_max(id, new_value, per_step_multiplier, ierr)
1389 0 : use relax, only: do_relax_opacity_max
1390 : integer, intent(in) :: id
1391 : real(dp), intent(in) :: new_value
1392 : real(dp), intent(in) :: per_step_multiplier
1393 : integer, intent(out) :: ierr
1394 0 : call do_relax_opacity_max(id, new_value, per_step_multiplier, ierr)
1395 0 : end subroutine star_relax_opacity_max
1396 :
1397 :
1398 0 : subroutine star_relax_max_surf_dq(id, new_value, per_step_multiplier, ierr)
1399 0 : use relax, only: do_relax_max_surf_dq
1400 : integer, intent(in) :: id
1401 : real(dp), intent(in) :: new_value
1402 : real(dp), intent(in) :: per_step_multiplier
1403 : integer, intent(out) :: ierr
1404 0 : call do_relax_max_surf_dq(id, new_value, per_step_multiplier, ierr)
1405 0 : end subroutine star_relax_max_surf_dq
1406 :
1407 :
1408 0 : subroutine star_relax_composition( &
1409 0 : id, num_steps_to_use, num_pts, species, xa, xq, ierr)
1410 : ! with normal composition changes turned off,
1411 : ! incrementally revise composition to get requested profile
1412 0 : use relax, only: do_relax_composition
1413 : integer, intent(in) :: id
1414 : integer, intent(in) :: num_steps_to_use ! use this many steps to do conversion
1415 : integer, intent(in) :: num_pts
1416 : ! length of composition vector; need not equal nz for current model (will interpolate)
1417 : integer, intent(in) :: species
1418 : ! must = number of species for current model
1419 : real(dp), intent(in) :: xa(:,:) ! (species, num_pts) ! target composition profile
1420 : real(dp), intent(in) :: xq(:) ! (num_pts)
1421 : ! xq(i) = fraction of xmstar exterior to the point i
1422 : ! where xmstar = mstar - M_center
1423 : integer, intent(out) :: ierr
1424 0 : call do_relax_composition(id, num_steps_to_use, num_pts, species, xa, xq, ierr)
1425 0 : end subroutine star_relax_composition
1426 :
1427 0 : subroutine star_relax_angular_momentum( &
1428 0 : id, max_steps_to_use, num_pts, angular_momentum, xq, ierr)
1429 : ! with normal composition changes turned off,
1430 : ! add extra heating term to get requested entropy profile
1431 0 : use relax, only: do_relax_angular_momentum
1432 : integer, intent(in) :: id
1433 : integer, intent(in) :: max_steps_to_use ! use this many steps to do conversion
1434 : integer, intent(in) :: num_pts
1435 : ! length of angular momentum vector; need not equal nz for current model (will interpolate)
1436 : real(dp), intent(in) :: angular_momentum(:) ! (num_pts) ! target am profile
1437 : real(dp), intent(in) :: xq(:) ! (num_pts)
1438 : ! xq(i) = fraction of xmstar exterior to the point i
1439 : ! where xmstar = mstar - M_center
1440 : integer, intent(out) :: ierr
1441 0 : call do_relax_angular_momentum(id, max_steps_to_use, num_pts, angular_momentum, xq, ierr)
1442 0 : end subroutine star_relax_angular_momentum
1443 :
1444 0 : subroutine star_relax_entropy( &
1445 0 : id, max_steps_to_use, num_pts, entropy, xq, ierr)
1446 : ! with normal composition changes turned off,
1447 : ! add extra heating term to get requested entropy profile
1448 0 : use relax, only: do_relax_entropy
1449 : integer, intent(in) :: id
1450 : integer, intent(in) :: max_steps_to_use ! use this many steps to do conversion
1451 : integer, intent(in) :: num_pts
1452 : ! length of entropy vector; need not equal nz for current model (will interpolate)
1453 : real(dp), intent(in) :: entropy(:) ! (num_pts) ! target entropy profile
1454 : real(dp), intent(in) :: xq(:) ! (num_pts)
1455 : ! xq(i) = fraction of xmstar exterior to the point i
1456 : ! where xmstar = mstar - M_center
1457 : integer, intent(out) :: ierr
1458 0 : call do_relax_entropy(id, max_steps_to_use, num_pts, entropy, xq, ierr)
1459 0 : end subroutine star_relax_entropy
1460 :
1461 0 : subroutine star_relax_to_xaccrete(id, num_steps_to_use, ierr)
1462 : ! with normal composition changes turned off,
1463 : ! incrementally revise composition to get uniform match to current accretion specs
1464 0 : use relax, only: do_relax_to_xaccrete
1465 : integer, intent(in) :: id
1466 : integer, intent(in) :: num_steps_to_use ! use this many steps to do conversion
1467 : integer, intent(out) :: ierr
1468 0 : call do_relax_to_xaccrete(id, num_steps_to_use, ierr)
1469 0 : end subroutine star_relax_to_xaccrete
1470 :
1471 :
1472 0 : subroutine star_relax_Y(id, new_Y, dY, minq, maxq, ierr) ! also resets initial_y
1473 0 : use relax, only: do_relax_Y
1474 : integer, intent(in) :: id
1475 : real(dp), intent(in) :: new_Y
1476 : real(dp), intent(in) :: dY ! change Y by this amount per step
1477 : real(dp), intent(in) :: minq, maxq ! change in this q range
1478 : integer, intent(out) :: ierr
1479 0 : call do_relax_Y(id, new_Y, dY, minq, maxq, ierr)
1480 0 : end subroutine star_relax_Y
1481 :
1482 :
1483 0 : subroutine star_relax_Z(id, new_z, dlnz, minq, maxq, ierr) ! also resets initial_z
1484 0 : use relax, only: do_relax_Z
1485 : integer, intent(in) :: id
1486 : real(dp), intent(in) :: new_z
1487 : real(dp), intent(in) :: dlnz ! change lnz by this amount per step
1488 : real(dp), intent(in) :: minq, maxq ! change in this q range
1489 : integer, intent(out) :: ierr
1490 0 : call do_relax_Z(id, new_z, dlnz, minq, maxq, ierr)
1491 0 : end subroutine star_relax_Z
1492 :
1493 :
1494 : ! the optical depth of the outermost cell is tau_factor*tau_photosphere
1495 : ! for normal hydrostatic stellar evolution, tau_factor = 1
1496 : ! but in general, the limits are 0 < tau_factor <= 1,
1497 : ! so by making tau_factor << 1, you can include the atmosphere in the model.
1498 0 : subroutine star_relax_tau_factor(id, new_tau_factor, dlogtau_factor, ierr)
1499 0 : use relax, only: do_relax_tau_factor
1500 : integer, intent(in) :: id
1501 : real(dp), intent(in) :: new_tau_factor
1502 : real(dp), intent(in) :: dlogtau_factor
1503 : ! change log10(tau_factor) by at most this amount per step
1504 : integer, intent(out) :: ierr
1505 0 : call do_relax_tau_factor(id, new_tau_factor, dlogtau_factor, ierr)
1506 0 : end subroutine star_relax_tau_factor
1507 :
1508 :
1509 : ! for normal stellar evolution, opacity_factor = 1
1510 : ! but for post-breakout CCSN, the expansion effects can be approximated by increasing kap.
1511 0 : subroutine star_relax_opacity_factor(id, new_opacity_factor, dopacity_factor, ierr)
1512 0 : use relax, only: do_relax_opacity_factor
1513 : integer, intent(in) :: id
1514 : real(dp), intent(in) :: new_opacity_factor
1515 : real(dp), intent(in) :: dopacity_factor
1516 : ! change opacity_factor by at most this amount per step
1517 : integer, intent(out) :: ierr
1518 0 : call do_relax_opacity_factor(id, new_opacity_factor, dopacity_factor, ierr)
1519 0 : end subroutine star_relax_opacity_factor
1520 :
1521 :
1522 0 : subroutine star_relax_Tsurf_factor(id, new_Tsurf_factor, dlogTsurf_factor, ierr)
1523 0 : use relax, only: do_relax_Tsurf_factor
1524 : integer, intent(in) :: id
1525 : real(dp), intent(in) :: new_Tsurf_factor
1526 : real(dp), intent(in) :: dlogTsurf_factor
1527 : ! change log10(Tsurf_factor) by at most this amount per step
1528 : integer, intent(out) :: ierr
1529 0 : call do_relax_Tsurf_factor(id, new_Tsurf_factor, dlogTsurf_factor, ierr)
1530 0 : end subroutine star_relax_Tsurf_factor
1531 :
1532 :
1533 : ! kind_of_relax = 0 => target = new_omega
1534 : ! kind_of_relax = 1 => target = new_omega_div_omega_crit
1535 : ! kind_of_relax = 2 => target = new_surface_rotation_v
1536 0 : subroutine star_relax_uniform_omega(id, &
1537 : kind_of_relax, target_value, num_steps_to_relax_rotation, &
1538 : relax_omega_max_yrs_dt, ierr)
1539 0 : use relax, only: do_relax_uniform_omega
1540 : integer, intent(in) :: id, kind_of_relax, num_steps_to_relax_rotation
1541 : real(dp), intent(in) :: target_value,relax_omega_max_yrs_dt
1542 : integer, intent(out) :: ierr
1543 : call do_relax_uniform_omega(id, &
1544 : kind_of_relax, target_value, num_steps_to_relax_rotation, &
1545 0 : relax_omega_max_yrs_dt, ierr)
1546 0 : end subroutine star_relax_uniform_omega
1547 :
1548 :
1549 0 : subroutine star_relax_irradiation(id, &
1550 : min_steps, new_irrad_flux, new_irrad_col_depth, &
1551 : relax_irradiation_max_yrs_dt, ierr)
1552 0 : use relax, only: do_relax_irradiation
1553 : integer, intent(in) :: id, min_steps
1554 : real(dp), intent(in) :: &
1555 : new_irrad_flux, new_irrad_col_depth, relax_irradiation_max_yrs_dt
1556 : integer, intent(out) :: ierr
1557 : call do_relax_irradiation(id, &
1558 0 : min_steps, new_irrad_flux, new_irrad_col_depth, relax_irradiation_max_yrs_dt, ierr)
1559 0 : end subroutine star_relax_irradiation
1560 :
1561 :
1562 0 : subroutine star_relax_mass_change( &
1563 : id, min_steps, initial_mass_change, final_mass_change, relax_mass_change_max_yrs_dt, ierr)
1564 0 : use relax, only: do_relax_mass_change
1565 : integer, intent(in) :: id, min_steps
1566 : real(dp), intent(in) :: initial_mass_change, final_mass_change, relax_mass_change_max_yrs_dt
1567 : integer, intent(out) :: ierr
1568 : call do_relax_mass_change( &
1569 0 : id, min_steps, initial_mass_change, final_mass_change, relax_mass_change_max_yrs_dt, ierr)
1570 0 : end subroutine star_relax_mass_change
1571 :
1572 :
1573 0 : subroutine star_relax_num_steps(id, num_steps, max_timestep, ierr)
1574 0 : use relax, only: do_relax_num_steps
1575 : integer, intent(in) :: id, num_steps
1576 : real(dp), intent(in) :: max_timestep
1577 : integer, intent(out) :: ierr
1578 0 : call do_relax_num_steps(id, num_steps, max_timestep, ierr)
1579 0 : end subroutine star_relax_num_steps
1580 :
1581 :
1582 : ! evolve until star_check_limits returns terminate.
1583 0 : subroutine star_evolve_to_limit(id, restore_at_end, ierr)
1584 0 : use relax, only: do_relax_to_limit
1585 : integer, intent(in) :: id
1586 : logical, intent(in) :: restore_at_end
1587 : integer, intent(out) :: ierr
1588 0 : call do_relax_to_limit(id, restore_at_end, ierr)
1589 0 : end subroutine star_evolve_to_limit
1590 :
1591 :
1592 : ! evolve until check_model says to stop.
1593 : ! this is intended for use in special "relax to" operations.
1594 : ! for normal evolution, you will probably want to use the ./rn script.
1595 0 : subroutine star_evolve_to_check_point( &
1596 : id, before_evolve, adjust_model, check_model, finish_model, &
1597 : restore_at_end, lipar, ipar, lrpar, rpar, ierr)
1598 0 : use relax, only: do_internal_evolve
1599 : integer, intent(in) :: id, lipar, lrpar
1600 : logical, intent(in) :: restore_at_end
1601 : integer, intent(inout), pointer :: ipar(:) ! (lipar)
1602 : real(dp), intent(inout), pointer :: rpar(:) ! (lrpar)
1603 : interface
1604 : subroutine before_evolve(s, id, lipar, ipar, lrpar, rpar, ierr)
1605 : use const_def, only: dp
1606 : use star_def, only: star_info
1607 : implicit none
1608 : type (star_info), pointer :: s
1609 : integer, intent(in) :: id, lipar, lrpar
1610 : integer, intent(inout), pointer :: ipar(:) ! (lipar)
1611 : real(dp), intent(inout), pointer :: rpar(:) ! (lrpar)
1612 : integer, intent(out) :: ierr
1613 : end subroutine before_evolve
1614 : integer function adjust_model(s, id, lipar, ipar, lrpar, rpar)
1615 : ! returns either keep_going, redo, retry, or terminate.
1616 : ! for okay termination, set s% termination_code = t_relax_finished_okay
1617 : use const_def, only: dp
1618 : use star_def, only: star_info
1619 : implicit none
1620 : type (star_info), pointer :: s
1621 : integer, intent(in) :: id, lipar, lrpar
1622 : integer, intent(inout), pointer :: ipar(:) ! (lipar)
1623 : real(dp), intent(inout), pointer :: rpar(:) ! (lrpar)
1624 : end function adjust_model
1625 : integer function check_model(s, id, lipar, ipar, lrpar, rpar)
1626 : ! returns either keep_going, redo, retry, or terminate.
1627 : ! for okay termination, set s% termination_code = t_relax_finished_okay
1628 : use const_def, only: dp
1629 : use star_def, only: star_info
1630 : implicit none
1631 : type (star_info), pointer :: s
1632 : integer, intent(in) :: id, lipar, lrpar
1633 : integer, intent(inout), pointer :: ipar(:) ! (lipar)
1634 : real(dp), intent(inout), pointer :: rpar(:) ! (lrpar)
1635 : end function check_model
1636 : integer function finish_model(s)
1637 : use star_def, only:star_info
1638 : implicit none
1639 : type (star_info), pointer :: s
1640 : end function finish_model
1641 : end interface
1642 : integer, intent(out) :: ierr
1643 : call do_internal_evolve( &
1644 : id, before_evolve, adjust_model, check_model, finish_model, &
1645 0 : restore_at_end, lipar, ipar, lrpar, rpar, ierr)
1646 0 : end subroutine star_evolve_to_check_point
1647 :
1648 :
1649 : ! I use this sometimes for debugging.
1650 0 : subroutine star_special_test(id, ierr)
1651 : integer, intent(in) :: id
1652 : integer, intent(out) :: ierr
1653 : type (star_info), pointer :: s
1654 : ierr = 0
1655 0 : call star_ptr(id, s, ierr)
1656 0 : if (ierr /= 0) return
1657 0 : end subroutine star_special_test
1658 :
1659 :
1660 : ! rotation
1661 :
1662 : ! note: this applies to the current model only;
1663 : ! subsequent models may evolve away from solid body rotation.
1664 0 : subroutine star_set_uniform_omega(id, omega, ierr)
1665 : use hydro_rotation, only: set_uniform_omega
1666 : integer, intent(in) :: id
1667 : real(dp), intent(in) :: omega
1668 : integer, intent(out) :: ierr
1669 0 : call set_uniform_omega(id, omega, ierr)
1670 0 : end subroutine star_set_uniform_omega
1671 :
1672 :
1673 : ! a few miscellaneous extra routines for special jobs
1674 :
1675 :
1676 : ! call this if you want a description of the terminal log output
1677 0 : subroutine show_log_description(id, ierr)
1678 0 : use do_one_utils, only: do_show_log_description
1679 : integer, intent(in) :: id
1680 : integer, intent(out) :: ierr
1681 0 : call do_show_log_description(id, ierr)
1682 0 : end subroutine show_log_description
1683 :
1684 :
1685 : ! write the terminal header lines
1686 1 : subroutine show_terminal_header(id, ierr)
1687 0 : use do_one_utils, only: do_show_terminal_header
1688 : integer, intent(in) :: id
1689 : integer, intent(out) :: ierr
1690 : type (star_info), pointer :: s
1691 : ierr = 0
1692 1 : call star_ptr(id, s, ierr)
1693 1 : if (ierr /= 0) return
1694 1 : call do_show_terminal_header(s)
1695 1 : end subroutine show_terminal_header
1696 :
1697 :
1698 : ! write the terminal summary lines
1699 1 : subroutine write_terminal_summary(id, ierr)
1700 1 : use do_one_utils, only: do_terminal_summary
1701 : integer, intent(in) :: id
1702 : integer, intent(out) :: ierr
1703 : type (star_info), pointer :: s
1704 : ierr = 0
1705 1 : call star_ptr(id, s, ierr)
1706 1 : if (ierr /= 0) return
1707 1 : call do_terminal_summary(s)
1708 1 : end subroutine write_terminal_summary
1709 :
1710 :
1711 0 : subroutine star_set_vars(id, dt, ierr)
1712 1 : use hydro_vars, only: set_vars
1713 : integer, intent(in) :: id
1714 : real(dp), intent(in) :: dt
1715 : integer, intent(out) :: ierr
1716 : type (star_info), pointer :: s
1717 : ierr = 0
1718 0 : call star_ptr(id, s, ierr)
1719 0 : if (ierr /= 0) return
1720 0 : call set_vars(s, dt, ierr)
1721 0 : end subroutine star_set_vars
1722 :
1723 :
1724 0 : subroutine star_set_power_info(s)
1725 0 : use report, only: set_power_info
1726 : type (star_info), pointer :: s
1727 0 : call set_power_info(s)
1728 0 : end subroutine star_set_power_info
1729 :
1730 :
1731 1 : subroutine save_profile(id, priority, ierr)
1732 0 : use profile, only: do_save_profiles
1733 : integer, intent(in) :: id
1734 : integer, intent(in) :: priority
1735 : ! there is a limit to how many profiles are saved,
1736 : ! and lower priority models are discarded if necessary
1737 : ! to make room for higher priority ones.
1738 : integer, intent(out) :: ierr
1739 : type (star_info), pointer :: s
1740 : ierr = 0
1741 1 : call star_ptr(id, s, ierr)
1742 1 : if (ierr /= 0) return
1743 1 : s% save_profiles_model_priority = priority
1744 1 : call do_save_profiles(s, ierr)
1745 1 : end subroutine save_profile
1746 :
1747 :
1748 0 : subroutine star_write_profile_info(id, fname, ierr)
1749 1 : use profile, only: write_profile_info
1750 : integer, intent(in) :: id
1751 : character (len=*) :: fname
1752 : integer, intent(out) :: ierr
1753 : type (star_info), pointer :: s
1754 : ierr = 0
1755 0 : call star_ptr(id, s, ierr)
1756 0 : if (ierr /= 0) return
1757 0 : call write_profile_info(s, fname, ierr)
1758 0 : end subroutine star_write_profile_info
1759 :
1760 :
1761 0 : subroutine name_for_restart_file(val, photo_digits, num_string)
1762 : integer, intent(in) :: val, photo_digits
1763 : character (len=*), intent(out) :: num_string
1764 0 : call string_for_model_number('x', val, photo_digits, num_string)
1765 0 : end subroutine name_for_restart_file
1766 :
1767 :
1768 0 : subroutine string_for_model_number(prefix, n, num_digits, num_string)
1769 : use star_utils, only: get_string_for_model_number
1770 : character (len=*), intent(in) :: prefix
1771 : integer, intent(in) :: n, num_digits
1772 : character (len=*), intent(out) :: num_string
1773 0 : call get_string_for_model_number(prefix, n, num_digits, num_string)
1774 0 : end subroutine string_for_model_number
1775 :
1776 :
1777 : ! a lightweight replacement for star_check_model
1778 0 : integer function bare_bones_check_model(id)
1779 0 : use do_one_utils, only: do_bare_bones_check_model
1780 : integer, intent(in) :: id
1781 0 : bare_bones_check_model = do_bare_bones_check_model(id)
1782 0 : end function bare_bones_check_model
1783 :
1784 :
1785 : ! get a value using the profile column id to specify
1786 0 : real(dp) function val_for_profile(s, c, k)
1787 0 : use profile_getval, only: getval_for_profile
1788 : type (star_info), pointer :: s
1789 : integer, intent(in) :: c ! one of the values like p_logL defined in star_def
1790 : integer, intent(in) :: k ! the zone number
1791 : logical :: int_flag
1792 : integer :: int_val
1793 0 : call getval_for_profile(s, c, k, val_for_profile, int_flag, int_val)
1794 0 : if (int_flag) val_for_profile = dble(int_val)
1795 0 : end function val_for_profile
1796 :
1797 :
1798 : ! get number of zones in current model
1799 0 : integer function star_zones(id, ierr)
1800 : integer, intent(in) :: id
1801 : integer, intent(out) :: ierr
1802 : type (star_info), pointer :: s
1803 0 : call star_ptr(id, s, ierr)
1804 0 : if (ierr /= 0) then
1805 0 : star_zones = -1
1806 : return
1807 : end if
1808 0 : star_zones = s% nz
1809 0 : end function star_zones
1810 :
1811 :
1812 0 : real(dp) function get_current_y(id, ierr)
1813 : use star_utils, only: eval_current_y
1814 : integer, intent(in) :: id
1815 : integer, intent(out) :: ierr
1816 : type (star_info), pointer :: s
1817 0 : call star_ptr(id, s, ierr)
1818 0 : if (ierr /= 0) then
1819 0 : get_current_y = -1
1820 : return
1821 : end if
1822 0 : get_current_y = eval_current_y(s, 1, s% nz, ierr)
1823 0 : end function get_current_y
1824 :
1825 :
1826 0 : real(dp) function get_current_y_in_section(id, nzlo, nzhi, ierr)
1827 0 : use star_utils, only: eval_current_y
1828 : integer, intent(in) :: id
1829 : integer, intent(in) :: nzlo, nzhi ! consider only zones nzlo to nzhi inclusive
1830 : integer, intent(out) :: ierr
1831 : type (star_info), pointer :: s
1832 0 : call star_ptr(id, s, ierr)
1833 0 : if (ierr /= 0) then
1834 0 : get_current_y_in_section = -1
1835 : return
1836 : end if
1837 0 : get_current_y_in_section = eval_current_y(s, nzlo, nzhi, ierr)
1838 0 : end function get_current_y_in_section
1839 :
1840 :
1841 0 : real(dp) function get_current_y_at_point(id, k, ierr)
1842 0 : use star_utils, only: eval_current_y
1843 : integer, intent(in) :: id
1844 : integer, intent(in) :: k ! between 1 and nz
1845 : integer, intent(out) :: ierr
1846 : type (star_info), pointer :: s
1847 0 : call star_ptr(id, s, ierr)
1848 0 : if (ierr /= 0) then
1849 0 : get_current_y_at_point = -1
1850 : return
1851 : end if
1852 0 : get_current_y_at_point = eval_current_y(s, k, k, ierr)
1853 0 : end function get_current_y_at_point
1854 :
1855 :
1856 0 : real(dp) function get_current_z(id, ierr)
1857 0 : use star_utils, only: eval_current_z
1858 : integer, intent(in) :: id
1859 : integer, intent(out) :: ierr
1860 : type (star_info), pointer :: s
1861 0 : call star_ptr(id, s, ierr)
1862 0 : if (ierr /= 0) then
1863 0 : get_current_z = -1
1864 : return
1865 : end if
1866 0 : get_current_z = eval_current_z(s, 1, s% nz, ierr)
1867 0 : end function get_current_z
1868 :
1869 :
1870 0 : real(dp) function get_current_z_in_section(id, nzlo, nzhi, ierr)
1871 0 : use star_utils, only: eval_current_z
1872 : integer, intent(in) :: id
1873 : integer, intent(in) :: nzlo, nzhi ! consider only zones nzlo to nzhi inclusive
1874 : integer, intent(out) :: ierr
1875 : type (star_info), pointer :: s
1876 0 : call star_ptr(id, s, ierr)
1877 0 : if (ierr /= 0) then
1878 0 : get_current_z_in_section = -1
1879 : return
1880 : end if
1881 0 : get_current_z_in_section = eval_current_z(s, nzlo, nzhi, ierr)
1882 0 : end function get_current_z_in_section
1883 :
1884 :
1885 0 : real(dp) function get_current_z_at_point(id, k, ierr)
1886 0 : use star_utils, only: eval_current_z
1887 : integer, intent(in) :: id
1888 : integer, intent(in) :: k ! between 1 and nz
1889 : integer, intent(out) :: ierr
1890 : type (star_info), pointer :: s
1891 0 : call star_ptr(id, s, ierr)
1892 0 : if (ierr /= 0) then
1893 0 : get_current_z_at_point = -1
1894 : return
1895 : end if
1896 0 : get_current_z_at_point = eval_current_z(s, k, k, ierr)
1897 0 : end function get_current_z_at_point
1898 :
1899 :
1900 0 : real(dp) function get_current_abundance(id, iso, ierr)
1901 : ! returns mass fraction for iso
1902 0 : use star_utils, only: eval_current_abundance
1903 : integer, intent(in) :: id
1904 : integer, intent(in) :: iso ! chem id from chem_def
1905 : integer, intent(out) :: ierr
1906 : type (star_info), pointer :: s
1907 0 : call star_ptr(id, s, ierr)
1908 0 : if (ierr /= 0) then
1909 0 : get_current_abundance = -1
1910 : return
1911 : end if
1912 : get_current_abundance = &
1913 0 : eval_current_abundance(s, s% net_iso(iso), 1, s% nz, ierr)
1914 0 : end function get_current_abundance
1915 :
1916 :
1917 11 : real(dp) function current_abundance_in_section(id, iso, nzlo, nzhi, ierr)
1918 : ! returns mass fraction for iso
1919 0 : use star_utils, only: eval_current_abundance
1920 : integer, intent(in) :: id
1921 : integer, intent(in) :: iso ! chem id from chem_def
1922 : integer, intent(in) :: nzlo, nzhi ! consider only zones nzlo to nzhi inclusive
1923 : integer, intent(out) :: ierr
1924 : type (star_info), pointer :: s
1925 11 : call star_ptr(id, s, ierr)
1926 11 : if (ierr /= 0) then
1927 11 : current_abundance_in_section = -1
1928 : return
1929 : end if
1930 : current_abundance_in_section = &
1931 11 : eval_current_abundance(s, s% net_iso(iso), nzlo, nzhi, ierr)
1932 11 : end function current_abundance_in_section
1933 :
1934 :
1935 11 : real(dp) function current_abundance_at_point(id, iso, k, ierr)
1936 : ! returns mass fraction for iso
1937 11 : use star_utils, only: eval_current_abundance
1938 : integer, intent(in) :: id
1939 : integer, intent(in) :: iso ! chem id from chem_def
1940 : integer, intent(in) :: k
1941 : integer, intent(out) :: ierr
1942 11 : current_abundance_at_point = current_abundance_in_section(id, iso, k, k, ierr)
1943 11 : end function current_abundance_at_point
1944 :
1945 :
1946 0 : subroutine star_get_XYZ(id, xa, X, Y, Z, ierr)
1947 11 : use star_utils, only: get_XYZ
1948 : integer, intent(in) :: id
1949 : real(dp), intent(in) :: xa(:)
1950 : real(dp), intent(out) :: X, Y, Z
1951 : integer, intent(out) :: ierr
1952 : type (star_info), pointer :: s
1953 : ierr = 0
1954 0 : call star_ptr(id, s, ierr)
1955 0 : if (ierr /= 0) return
1956 0 : call get_XYZ(s, xa, X, Y, Z)
1957 0 : end subroutine star_get_XYZ
1958 :
1959 :
1960 0 : subroutine star_xa_for_standard_metals( &
1961 0 : s, species, chem_id, net_iso, &
1962 : h1, h2, he3, he4, which_zfracs, &
1963 0 : dump_missing_metals_into_heaviest, xa, ierr)
1964 0 : use adjust_xyz, only: get_xa_for_standard_metals
1965 : type (star_info), pointer :: s
1966 : integer, intent(in) :: species, chem_id(:), net_iso(:), which_zfracs
1967 : real(dp), intent(in) :: h1, h2, he3, he4 ! mass fractions
1968 : logical, intent(in) :: dump_missing_metals_into_heaviest
1969 : real(dp), intent(inout) :: xa(:) ! (species)
1970 : integer, intent(out) :: ierr
1971 : call get_xa_for_standard_metals( &
1972 : s, species, chem_id, net_iso, &
1973 : h1, h2, he3, he4, which_zfracs, &
1974 0 : dump_missing_metals_into_heaviest, xa, ierr)
1975 0 : end subroutine star_xa_for_standard_metals
1976 :
1977 :
1978 0 : subroutine star_info_at_q(s, q, &
1979 : kbdy, m, r, lgT, lgRho, L, v, &
1980 : lgP, g, X, Y, scale_height, dlnX_dr, dlnY_dr, dlnRho_dr, &
1981 : omega, omega_div_omega_crit)
1982 0 : use report, only: get_info_at_q
1983 : type (star_info), pointer :: s
1984 : real(dp), intent(in) :: q ! relative mass coord
1985 : integer, intent(out) :: kbdy
1986 : real(dp), intent(out) :: &
1987 : m, r, lgT, lgRho, L, v, &
1988 : lgP, g, X, Y, scale_height, dlnX_dr, dlnY_dr, dlnRho_dr, &
1989 : omega, omega_div_omega_crit
1990 : call get_info_at_q(s, q, &
1991 : kbdy, m, r, lgT, lgRho, L, v, &
1992 : lgP, g, X, Y, scale_height, dlnX_dr, dlnY_dr, dlnRho_dr, &
1993 0 : omega, omega_div_omega_crit)
1994 0 : end subroutine star_info_at_q
1995 :
1996 :
1997 12 : integer function get_model_number(id, ierr)
1998 : integer, intent(in) :: id
1999 : integer, intent(out) :: ierr
2000 : type (star_info), pointer :: s
2001 12 : call star_ptr(id, s, ierr)
2002 12 : if (ierr /= 0) then
2003 12 : get_model_number = -1
2004 : return
2005 : end if
2006 12 : get_model_number = s% model_number
2007 12 : end function get_model_number
2008 :
2009 :
2010 0 : logical function check_for_after_He_burn(s, he4_limit)
2011 : use star_utils, only: after_He_burn
2012 : type (star_info), pointer :: s
2013 : real(dp), intent(in) :: he4_limit
2014 0 : check_for_after_He_burn = after_He_burn(s, he4_limit)
2015 0 : end function check_for_after_He_burn
2016 :
2017 :
2018 0 : logical function check_for_after_C_burn(s, c12_limit)
2019 0 : use star_utils, only: after_C_burn
2020 : type (star_info), pointer :: s
2021 : real(dp), intent(in) :: c12_limit
2022 0 : check_for_after_C_burn = after_C_burn(s, c12_limit)
2023 0 : end function check_for_after_C_burn
2024 :
2025 :
2026 : ! intrinsic variables like T, Rho, kap, etc. are cell averages
2027 : ! this routine returns an interpolated value at outer boundary of cell k
2028 0 : real(dp) function star_interp_val_to_pt(v,k,sz,dq,debug_str)
2029 0 : use star_utils, only: interp_val_to_pt
2030 : integer, intent(in) :: k, sz
2031 : real(dp), pointer :: v(:), dq(:) ! (sz)
2032 : character (len=*), intent(in) :: debug_str
2033 0 : star_interp_val_to_pt = interp_val_to_pt(v,k,sz,dq,debug_str)
2034 0 : end function star_interp_val_to_pt
2035 :
2036 :
2037 : ! this routine returns an interpolated value of xa(j,:) at outer boundary of cell k
2038 0 : real(dp) function star_interp_xa_to_pt(xa,j,k,sz,dq,debug_str)
2039 0 : use star_utils, only: interp_xa_to_pt
2040 : real(dp), pointer :: xa(:,:), dq(:) ! (sz)
2041 : integer, intent(in) :: j, k, sz
2042 : character (len=*), intent(in) :: debug_str
2043 0 : star_interp_xa_to_pt = interp_xa_to_pt(xa,j,k,sz,dq,debug_str)
2044 0 : end function star_interp_xa_to_pt
2045 : ! misc routines
2046 :
2047 :
2048 0 : subroutine star_set_xqs(nz, xq, dq, ierr) ! set xq's using dq's
2049 0 : use star_utils, only: set_xqs
2050 : integer, intent(in) :: nz
2051 : real(dp), intent(inout) :: dq(:) ! (nz)
2052 : real(dp), intent(inout) :: xq(:) ! (nz)
2053 : integer, intent(out) :: ierr
2054 0 : call set_xqs(nz, xq, dq, ierr)
2055 0 : end subroutine star_set_xqs
2056 :
2057 :
2058 0 : subroutine star_get_eos( &
2059 0 : id, k, xa, &
2060 : Rho, logRho, T, logT, &
2061 : res, dres_dlnRho, dres_dlnT, &
2062 0 : dres_dxa, ierr)
2063 0 : use eos_def, only: num_eos_basic_results
2064 : use eos_support, only: get_eos
2065 : integer, intent(in) :: id
2066 : integer, intent(in) :: k ! 0 means not being called for a particular cell
2067 : real(dp), intent(in) :: xa(:), Rho, logRho, T, logT
2068 : real(dp), dimension(num_eos_basic_results), intent(out) :: &
2069 : res, dres_dlnRho, dres_dlnT
2070 : real(dp), intent(out) :: dres_dxa(:,:)
2071 : integer, intent(out) :: ierr
2072 : type (star_info), pointer :: s
2073 : ierr = 0
2074 0 : call star_ptr(id, s, ierr)
2075 0 : if (ierr /= 0) return
2076 : call get_eos( &
2077 : s, k, xa, &
2078 : Rho, logRho, T, logT, &
2079 : res, dres_dlnRho, dres_dlnT, &
2080 0 : dres_dxa, ierr)
2081 0 : end subroutine star_get_eos
2082 :
2083 0 : subroutine star_get_peos( &
2084 : id, k, xa, &
2085 : Pgas, logPgas, T, logT, &
2086 : Rho, logRho, dlnRho_dlnPgas, dlnRho_dlnT, &
2087 : res, dres_dlnRho, dres_dlnT, &
2088 : dres_dxa, ierr)
2089 0 : use eos_def, only: num_eos_basic_results
2090 : !use eos_support, only: get_peos
2091 : integer, intent(in) :: id
2092 : integer, intent(in) :: k ! 0 means not being called for a particular cell
2093 : real(dp), intent(in) :: xa(:), Pgas, logPgas, T, logT
2094 : real(dp), intent(out) :: &
2095 : Rho, logRho, dlnRho_dlnPgas, dlnRho_dlnT
2096 : real(dp), dimension(num_eos_basic_results), intent(out) :: &
2097 : res, dres_dlnRho, dres_dlnT
2098 : real(dp), intent(out) :: dres_dxa(:,:)
2099 : integer, intent(out) :: ierr
2100 : !type (star_info), pointer :: s
2101 : !ierr = 0
2102 : !call star_ptr(id, s, ierr)
2103 : !if (ierr /= 0) return
2104 : !call get_peos ( &
2105 : ! s, k, xa, &
2106 : ! Pgas, logPgas, T, logT, &
2107 : ! Rho, logRho, dlnRho_dlnPgas, dlnRho_dlnT, &
2108 : ! res, dres_dlnRho, dres_dlnT, dres_dxa, ierr)
2109 0 : ierr = -1
2110 0 : write(*,*) 'star_get_peos no longer supported'
2111 0 : call mesa_error(__FILE__,__LINE__)
2112 0 : end subroutine star_get_peos
2113 :
2114 0 : subroutine star_solve_eos_given_PgasT( &
2115 0 : id, k, xa, &
2116 : logT, logPgas, logRho_guess, logRho_tol, logPgas_tol, &
2117 0 : logRho, res, dres_dlnRho, dres_dlnT, dres_dxa, &
2118 : ierr)
2119 0 : use eos_def, only: num_eos_basic_results, num_eos_d_dxa_results
2120 : use eos_support, only : solve_eos_given_PgasT
2121 : integer, intent(in) :: id
2122 : integer, intent(in) :: k ! 0 indicates not for a particular cell.
2123 : real(dp), intent(in) :: &
2124 : xa(:), logT, logPgas, &
2125 : logRho_guess, logRho_tol, logPgas_tol
2126 : real(dp), intent(out) :: logRho
2127 : real(dp), dimension(num_eos_basic_results), intent(out) :: &
2128 : res, dres_dlnRho, dres_dlnT
2129 : real(dp), dimension(:,:), intent(out) :: dres_dxa
2130 : integer, intent(out) :: ierr
2131 : type (star_info), pointer :: s
2132 : ierr = 0
2133 0 : call star_ptr(id, s, ierr)
2134 0 : if (ierr /= 0) return
2135 : call solve_eos_given_PgasT( &
2136 : s, k, xa, &
2137 : logT, logPgas, logRho_guess, logRho_tol, logPgas_tol, &
2138 : logRho, res, dres_dlnRho, dres_dlnT, dres_dxa, &
2139 0 : ierr)
2140 0 : end subroutine star_solve_eos_given_PgasT
2141 :
2142 0 : subroutine star_solve_eos_given_PgasT_auto( &
2143 0 : id, k, xa, &
2144 : logT, logPgas, logRho_tol, logPgas_tol, &
2145 0 : logRho, res, dres_dlnRho, dres_dlnT, dres_dxa, &
2146 : ierr)
2147 0 : use eos_def, only: num_eos_basic_results, num_eos_d_dxa_results
2148 : use eos_support, only: solve_eos_given_PgasT_auto
2149 : use star_def
2150 : integer, intent(in) :: id ! id for star
2151 : integer, intent(in) :: k ! 0 indicates not for a particular cell.
2152 : real(dp), intent(in) :: &
2153 : xa(:), logT, logPgas, &
2154 : logRho_tol, logPgas_tol
2155 : real(dp), intent(out) :: logRho
2156 : real(dp), dimension(num_eos_basic_results), intent(out) :: &
2157 : res, dres_dlnRho, dres_dlnT
2158 : real(dp), dimension(:,:), intent(out) :: dres_dxa
2159 : integer, intent(out) :: ierr
2160 : type (star_info), pointer :: s
2161 0 : call star_ptr(id, s, ierr)
2162 0 : if (ierr /= 0) return
2163 : call solve_eos_given_PgasT_auto( &
2164 : s, k, xa, &
2165 : logT, logPgas, logRho_tol, logPgas_tol, &
2166 : logRho, res, dres_dlnRho, dres_dlnT, dres_dxa, &
2167 0 : ierr)
2168 0 : end subroutine star_solve_eos_given_PgasT_auto
2169 :
2170 0 : subroutine star_get_kap( &
2171 : id, k, zbar, xa, logRho, logT, &
2172 : lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT, &
2173 : eta, deta_dlnRho, deta_dlnT, &
2174 : kap_fracs, kap, dlnkap_dlnRho, dlnkap_dlnT, ierr)
2175 0 : use kap_def, only: num_kap_fracs
2176 : use kap_support, only: get_kap, fraction_of_op_mono
2177 : integer, intent(in) :: id
2178 : integer, intent(in) :: k
2179 : real(dp), intent(in) :: zbar, logRho, logT, &
2180 : lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT, &
2181 : eta, deta_dlnRho, deta_dlnT
2182 : real(dp), intent(in), pointer :: xa(:)
2183 : real(dp), intent(out) :: kap_fracs(num_kap_fracs)
2184 : real(dp), intent(out) :: kap, dlnkap_dlnRho, dlnkap_dlnT
2185 : integer, intent(out) :: ierr
2186 : type (star_info), pointer :: s
2187 : ierr = 0
2188 0 : call star_ptr(id, s, ierr)
2189 0 : if (ierr /= 0) return
2190 : call get_kap( &
2191 : s, k, zbar, xa, logRho, logT, &
2192 : lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT, &
2193 : eta, deta_dlnRho, deta_dlnT, &
2194 0 : kap_fracs, kap, dlnkap_dlnRho, dlnkap_dlnT, ierr)
2195 0 : end subroutine star_get_kap
2196 :
2197 0 : subroutine star_do_eos_for_cell(id, k, ierr)
2198 0 : use micro, only: do_eos_for_cell
2199 : integer, intent(in) :: id
2200 : integer, intent(in) :: k
2201 : integer, intent(out) :: ierr
2202 : type (star_info), pointer :: s
2203 : ierr = 0
2204 0 : call star_ptr(id, s, ierr)
2205 0 : if (ierr /= 0) return
2206 0 : call do_eos_for_cell(s, k, ierr)
2207 0 : end subroutine star_do_eos_for_cell
2208 :
2209 :
2210 0 : subroutine star_do_kap_for_cell(id, k, ierr)
2211 0 : use micro, only: do_kap_for_cell
2212 : integer, intent(in) :: id
2213 : integer, intent(in) :: k
2214 : integer, intent(out) :: ierr
2215 : type (star_info), pointer :: s
2216 : ierr = 0
2217 0 : call star_ptr(id, s, ierr)
2218 0 : if (ierr /= 0) return
2219 0 : call do_kap_for_cell(s, k, ierr)
2220 0 : end subroutine star_do_kap_for_cell
2221 :
2222 :
2223 0 : subroutine star_get_atm_PT( &
2224 : id, tau_surf, L, R, M, cgrav, skip_partials, Teff, &
2225 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2226 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap, &
2227 : ierr)
2228 0 : use atm_support, only: get_atm_PT
2229 : integer, intent(in) :: id
2230 : real(dp), intent(in) :: tau_surf, L, R, M, cgrav
2231 : logical, intent(in) :: skip_partials
2232 : real(dp), intent(in) :: Teff
2233 : real(dp), intent(out) :: &
2234 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2235 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap
2236 : integer, intent(out) :: ierr
2237 : type (star_info), pointer :: s
2238 : ierr = 0
2239 0 : call star_ptr(id, s, ierr)
2240 0 : if (ierr /= 0) return
2241 : call get_atm_PT( &
2242 : s, tau_surf, L, R, M, cgrav, skip_partials, &
2243 : Teff, &
2244 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2245 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap, &
2246 0 : ierr)
2247 0 : end subroutine star_get_atm_PT
2248 :
2249 :
2250 0 : subroutine star_get_surf_PT( &
2251 : id, skip_partials, need_atm_Psurf, need_atm_Tsurf, &
2252 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2253 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap, &
2254 : ierr)
2255 0 : use hydro_vars, only: get_surf_PT
2256 : integer, intent(in) :: id
2257 : logical, intent(in) :: skip_partials, need_atm_Psurf, need_atm_Tsurf
2258 : real(dp), intent(out) :: &
2259 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2260 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap
2261 : integer, intent(out) :: ierr
2262 : type (star_info), pointer :: s
2263 : ierr = 0
2264 0 : call star_ptr(id, s, ierr)
2265 0 : if (ierr /= 0) return
2266 : call get_surf_PT( &
2267 : s, skip_partials, need_atm_Psurf, need_atm_Tsurf, &
2268 : lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, &
2269 : lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap, &
2270 0 : ierr)
2271 0 : end subroutine star_get_surf_PT
2272 :
2273 0 : integer function get_result_reason(id, ierr)
2274 : integer, intent(in) :: id
2275 : integer, intent(out) :: ierr
2276 : type (star_info), pointer :: s
2277 0 : call star_ptr(id, s, ierr)
2278 0 : if (ierr /= 0) then
2279 0 : get_result_reason = -1
2280 : return
2281 : end if
2282 0 : get_result_reason = s% result_reason
2283 0 : end function get_result_reason
2284 :
2285 0 : real(dp) function eval_tau_at_r(id, r, ierr)
2286 : ! optical depth tau at radius r (cm)
2287 : ! r should be <= s% r(1) and >= s% Rcenter
2288 : ! does linear interpolation wrt r within cell
2289 : use star_utils, only: get_tau_at_r
2290 : integer, intent(in) :: id
2291 : real(dp), intent(in) :: r
2292 : integer, intent(out) :: ierr
2293 : type (star_info), pointer :: s
2294 0 : call star_ptr(id, s, ierr)
2295 0 : if (ierr /= 0) then
2296 0 : eval_tau_at_r = -1
2297 : return
2298 : end if
2299 0 : eval_tau_at_r = get_tau_at_r(s, r, ierr)
2300 0 : end function eval_tau_at_r
2301 :
2302 :
2303 0 : real(dp) function eval_total_times(id, ierr)
2304 0 : use star_utils, only: total_times
2305 : integer, intent(in) :: id
2306 : integer, intent(out) :: ierr
2307 : type (star_info), pointer :: s
2308 0 : call star_ptr(id, s, ierr)
2309 0 : if (ierr /= 0) then
2310 0 : eval_total_times = -1
2311 : return
2312 : end if
2313 0 : eval_total_times = total_times(s)
2314 0 : end function eval_total_times
2315 :
2316 :
2317 0 : subroutine star_total_energy_integrals(id, &
2318 : total_internal_energy, total_gravitational_energy, &
2319 : total_radial_kinetic_energy, total_rotational_kinetic_energy, &
2320 : total_turbulent_energy, sum_total, ierr)
2321 0 : use star_utils, only: eval_total_energy_integrals
2322 : integer, intent(in) :: id
2323 : real(dp), intent(out) :: &
2324 : total_internal_energy, total_gravitational_energy, &
2325 : total_radial_kinetic_energy, total_rotational_kinetic_energy, &
2326 : total_turbulent_energy, sum_total
2327 : integer, intent(out) :: ierr
2328 : type (star_info), pointer :: s
2329 0 : call star_ptr(id, s, ierr)
2330 0 : if (ierr /= 0) return
2331 : call eval_total_energy_integrals(s, &
2332 : total_internal_energy, total_gravitational_energy, &
2333 : total_radial_kinetic_energy, total_rotational_kinetic_energy, &
2334 0 : total_turbulent_energy, sum_total)
2335 0 : end subroutine star_total_energy_integrals
2336 :
2337 :
2338 0 : real(dp) function star_surface_omega_crit(id, ierr)
2339 0 : use hydro_rotation, only: set_surf_avg_rotation_info
2340 : integer, intent(in) :: id
2341 : integer, intent(out) :: ierr
2342 : type (star_info), pointer :: s
2343 0 : call star_ptr(id, s, ierr)
2344 0 : if (ierr /= 0) then
2345 0 : star_surface_omega_crit = -1
2346 : return
2347 : end if
2348 0 : call set_surf_avg_rotation_info(s)
2349 0 : star_surface_omega_crit = s% omega_crit_avg_surf
2350 0 : end function star_surface_omega_crit
2351 :
2352 :
2353 : ! some routines for "stellar engineering"
2354 :
2355 0 : subroutine star_normalize_dqs(id, nz, dq, ierr)
2356 : ! rescale dq's so that add to 1.000
2357 : ! work in from boundaries to meet at largest dq
2358 0 : use star_utils, only: normalize_dqs
2359 : integer, intent(in) :: id
2360 : integer, intent(in) :: nz
2361 : real(dp), intent(inout) :: dq(:) ! (nz)
2362 : integer, intent(out) :: ierr
2363 : type (star_info), pointer :: s
2364 0 : call star_ptr(id, s, ierr)
2365 0 : if (ierr /= 0) return
2366 0 : call normalize_dqs(s, nz, dq, ierr)
2367 0 : end subroutine star_normalize_dqs
2368 :
2369 :
2370 0 : subroutine star_set_qs(id, nz, q, dq, ierr) ! set q's using normalized dq's
2371 0 : use star_utils, only: set_qs
2372 : integer, intent(in) :: id
2373 : integer, intent(in) :: nz
2374 : real(dp), intent(inout) :: dq(:) ! (nz)
2375 : real(dp), intent(inout) :: q(:) ! (nz)
2376 : integer, intent(out) :: ierr
2377 : type (star_info), pointer :: s
2378 0 : call star_ptr(id, s, ierr)
2379 0 : if (ierr /= 0) return
2380 0 : call set_qs(s, nz, q, dq, ierr)
2381 0 : end subroutine star_set_qs
2382 :
2383 :
2384 0 : subroutine star_set_m_and_dm(id, ierr)
2385 0 : use star_utils, only: set_m_and_dm
2386 : integer, intent(in) :: id
2387 : integer, intent(out) :: ierr
2388 : type (star_info), pointer :: s
2389 : ierr = 0
2390 0 : call star_ptr(id, s, ierr)
2391 0 : if (ierr /= 0) return
2392 0 : call set_m_and_dm(s)
2393 0 : end subroutine star_set_m_and_dm
2394 :
2395 :
2396 0 : subroutine star_set_dm_bar(id, ierr)
2397 0 : use star_utils, only: set_dm_bar
2398 : integer, intent(in) :: id
2399 : integer, intent(out) :: ierr
2400 : type (star_info), pointer :: s
2401 : ierr = 0
2402 0 : call star_ptr(id, s, ierr)
2403 0 : if (ierr /= 0) return
2404 0 : call set_dm_bar(s, s% nz, s% dm, s% dm_bar)
2405 0 : end subroutine star_set_dm_bar
2406 :
2407 :
2408 0 : subroutine star_remove_center_at_cell_k(id, k, ierr)
2409 0 : use remove_shells, only: do_remove_center_at_cell_k
2410 : integer, intent(in) :: id, k
2411 : integer, intent(out) :: ierr
2412 0 : call do_remove_center_at_cell_k(id, k, ierr)
2413 0 : end subroutine star_remove_center_at_cell_k
2414 :
2415 :
2416 0 : subroutine star_remove_center_by_temperature(id, temperature, ierr)
2417 0 : use remove_shells, only: do_remove_center_by_temperature
2418 : integer, intent(in) :: id
2419 : real(dp), intent(in) :: temperature
2420 : integer, intent(out) :: ierr
2421 0 : call do_remove_center_by_temperature(id, temperature, ierr)
2422 0 : end subroutine star_remove_center_by_temperature
2423 :
2424 :
2425 0 : subroutine star_remove_center_by_radius_cm(id, r_cm, ierr)
2426 0 : use remove_shells, only: do_remove_center_by_radius_cm
2427 : integer, intent(in) :: id
2428 : real(dp), intent(in) :: r_cm
2429 : integer, intent(out) :: ierr
2430 0 : call do_remove_center_by_radius_cm(id, r_cm, ierr)
2431 0 : end subroutine star_remove_center_by_radius_cm
2432 :
2433 :
2434 0 : subroutine star_remove_center_by_mass_fraction_q(id, q, ierr)
2435 0 : use remove_shells, only: do_remove_inner_fraction_q
2436 : integer, intent(in) :: id
2437 : real(dp), intent(in) :: q
2438 : integer, intent(out) :: ierr
2439 0 : call do_remove_inner_fraction_q(id, q, ierr)
2440 0 : end subroutine star_remove_center_by_mass_fraction_q
2441 :
2442 :
2443 0 : subroutine star_remove_center_by_he4(id, x, ierr)
2444 0 : use remove_shells, only: do_remove_center_by_he4
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_he4(id, x, ierr)
2449 0 : end subroutine star_remove_center_by_he4
2450 :
2451 :
2452 0 : subroutine star_remove_center_by_c12_o16(id, x, ierr)
2453 0 : use remove_shells, only: do_remove_center_by_c12_o16
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_c12_o16(id, x, ierr)
2458 0 : end subroutine star_remove_center_by_c12_o16
2459 :
2460 :
2461 0 : subroutine star_remove_center_by_si28(id, x, ierr)
2462 0 : use remove_shells, only: do_remove_center_by_si28
2463 : integer, intent(in) :: id
2464 : real(dp), intent(in) :: x ! mass fraction
2465 : integer, intent(out) :: ierr
2466 0 : call do_remove_center_by_si28(id, x, ierr)
2467 0 : end subroutine star_remove_center_by_si28
2468 :
2469 :
2470 0 : subroutine star_remove_center_to_reduce_co56_ni56(id, x, ierr)
2471 0 : use remove_shells, only: do_remove_center_to_reduce_co56_ni56
2472 : integer, intent(in) :: id
2473 : real(dp), intent(in) :: x ! mass fraction
2474 : integer, intent(out) :: ierr
2475 0 : call do_remove_center_to_reduce_co56_ni56(id, x, ierr)
2476 0 : end subroutine star_remove_center_to_reduce_co56_ni56
2477 :
2478 :
2479 0 : subroutine star_remove_center_by_ye(id, ye, ierr)
2480 0 : use remove_shells, only: do_remove_center_by_ye
2481 : integer, intent(in) :: id
2482 : real(dp), intent(in) :: ye
2483 : integer, intent(out) :: ierr
2484 0 : call do_remove_center_by_ye(id, ye, ierr)
2485 0 : end subroutine star_remove_center_by_ye
2486 :
2487 :
2488 0 : subroutine star_remove_center_by_entropy(id, entropy, ierr)
2489 0 : use remove_shells, only: do_remove_center_by_entropy
2490 : integer, intent(in) :: id
2491 : real(dp), intent(in) :: entropy
2492 : integer, intent(out) :: ierr
2493 0 : call do_remove_center_by_entropy(id, entropy, ierr)
2494 0 : end subroutine star_remove_center_by_entropy
2495 :
2496 :
2497 0 : subroutine star_remove_center_by_infall_kms(id, infall_kms, ierr)
2498 0 : use remove_shells, only: do_remove_center_by_infall_kms
2499 : integer, intent(in) :: id
2500 : real(dp), intent(in) :: infall_kms
2501 : integer, intent(out) :: ierr
2502 0 : call do_remove_center_by_infall_kms(id, infall_kms, ierr)
2503 0 : end subroutine star_remove_center_by_infall_kms
2504 :
2505 :
2506 0 : subroutine star_remove_center_at_inner_max_abs_v(id, ierr)
2507 0 : use remove_shells, only: do_remove_center_at_inner_max_abs_v
2508 : integer, intent(in) :: id
2509 : integer, intent(out) :: ierr
2510 0 : call do_remove_center_at_inner_max_abs_v(id, ierr)
2511 0 : end subroutine star_remove_center_at_inner_max_abs_v
2512 :
2513 :
2514 0 : subroutine star_remove_fe_core(id, ierr)
2515 0 : use remove_shells, only: do_remove_fe_core
2516 : integer, intent(in) :: id
2517 : integer, intent(out) :: ierr
2518 0 : call do_remove_fe_core(id, ierr)
2519 0 : end subroutine star_remove_fe_core
2520 :
2521 :
2522 0 : subroutine star_remove_center_by_mass_gm(id, m, ierr)
2523 0 : use remove_shells, only: do_remove_center_by_mass_gm
2524 : integer, intent(in) :: id
2525 : real(dp), intent(in) :: m
2526 : integer, intent(out) :: ierr
2527 0 : call do_remove_center_by_mass_gm(id, m, ierr)
2528 0 : end subroutine star_remove_center_by_mass_gm
2529 :
2530 :
2531 0 : subroutine star_zero_inner_v_by_mass_gm(id, m, ierr)
2532 0 : use remove_shells, only: do_zero_inner_v_by_mass_gm
2533 : integer, intent(in) :: id
2534 : real(dp), intent(in) :: m
2535 : integer, intent(out) :: ierr
2536 0 : call do_zero_inner_v_by_mass_gm(id, m, ierr)
2537 0 : end subroutine star_zero_inner_v_by_mass_gm
2538 :
2539 :
2540 0 : subroutine star_relax_to_star_cut(&
2541 : id, k_remove, do_jrot, do_entropy, turn_off_energy_sources_and_sinks, ierr)
2542 0 : use remove_shells, only: do_relax_to_star_cut
2543 :
2544 : integer, intent(in) :: id, k_remove
2545 : logical, intent(in) :: do_jrot, do_entropy
2546 : logical, intent(in) :: turn_off_energy_sources_and_sinks ! determines if we turn off non_nuc_neu and eps_nuc for entropy relax
2547 : integer, intent(out) :: ierr
2548 :
2549 0 : call do_relax_to_star_cut(id, k_remove, do_jrot, do_entropy, turn_off_energy_sources_and_sinks, ierr)
2550 0 : end subroutine star_relax_to_star_cut
2551 :
2552 :
2553 0 : subroutine star_remove_surface_by_v_surf_km_s(id, v_surf_km_s, ierr)
2554 0 : use remove_shells, only: do_remove_surface_by_v_surf_km_s
2555 : integer, intent(in) :: id
2556 : real(dp), intent(in) :: v_surf_km_s
2557 : integer, intent(out) :: ierr
2558 0 : call do_remove_surface_by_v_surf_km_s(id, v_surf_km_s, ierr)
2559 0 : end subroutine star_remove_surface_by_v_surf_km_s
2560 :
2561 :
2562 0 : subroutine star_remove_surface_by_v_surf_div_cs(id, v_surf_div_cs, ierr)
2563 0 : use remove_shells, only: do_remove_surface_by_v_surf_div_cs
2564 : integer, intent(in) :: id
2565 : real(dp), intent(in) :: v_surf_div_cs
2566 : integer, intent(out) :: ierr
2567 0 : call do_remove_surface_by_v_surf_div_cs(id, v_surf_div_cs, ierr)
2568 0 : end subroutine star_remove_surface_by_v_surf_div_cs
2569 :
2570 :
2571 0 : subroutine star_remove_surface_by_v_surf_div_v_escape(id, v_surf_div_v_escape, ierr)
2572 0 : use remove_shells, only: do_remove_surface_by_v_surf_div_v_escape
2573 : integer, intent(in) :: id
2574 : real(dp), intent(in) :: v_surf_div_v_escape
2575 : integer, intent(out) :: ierr
2576 0 : call do_remove_surface_by_v_surf_div_v_escape(id, v_surf_div_v_escape, ierr)
2577 0 : end subroutine star_remove_surface_by_v_surf_div_v_escape
2578 :
2579 :
2580 0 : subroutine star_remove_surface_at_cell_k(id, k, ierr)
2581 0 : use remove_shells, only: do_remove_surface_at_cell_k
2582 : integer, intent(in) :: id, k
2583 : integer, intent(out) :: ierr
2584 0 : call do_remove_surface_at_cell_k(id, k, ierr)
2585 0 : end subroutine star_remove_surface_at_cell_k
2586 :
2587 :
2588 0 : subroutine star_remove_surface_at_he_core_boundary(id, h1_fraction, ierr)
2589 0 : use remove_shells, only: do_remove_surface_at_he_core_boundary
2590 : integer, intent(in) :: id
2591 : real(dp), intent(in) :: h1_fraction
2592 : integer, intent(out) :: ierr
2593 0 : call do_remove_surface_at_he_core_boundary(id, h1_fraction, ierr)
2594 0 : end subroutine star_remove_surface_at_he_core_boundary
2595 :
2596 :
2597 0 : subroutine star_remove_surface_by_optical_depth(id, optical_depth, ierr)
2598 0 : use remove_shells, only: do_remove_surface_by_optical_depth
2599 : integer, intent(in) :: id
2600 : real(dp), intent(in) :: optical_depth
2601 : integer, intent(out) :: ierr
2602 0 : call do_remove_surface_by_optical_depth(id, optical_depth, ierr)
2603 0 : end subroutine star_remove_surface_by_optical_depth
2604 :
2605 :
2606 0 : subroutine star_remove_surface_by_density(id, density, ierr)
2607 0 : use remove_shells, only: do_remove_surface_by_density
2608 : integer, intent(in) :: id
2609 : real(dp), intent(in) :: density
2610 : integer, intent(out) :: ierr
2611 0 : call do_remove_surface_by_density(id, density, ierr)
2612 0 : end subroutine star_remove_surface_by_density
2613 :
2614 :
2615 0 : subroutine star_remove_surface_by_pressure(id, pressure, ierr)
2616 0 : use remove_shells, only: do_remove_surface_by_pressure
2617 : integer, intent(in) :: id
2618 : real(dp), intent(in) :: pressure
2619 : integer, intent(out) :: ierr
2620 0 : call do_remove_surface_by_pressure(id, pressure, ierr)
2621 0 : end subroutine star_remove_surface_by_pressure
2622 :
2623 :
2624 0 : subroutine star_remove_surface_by_radius_cm(id, r_cm, ierr)
2625 0 : use remove_shells, only: do_remove_surface_by_radius_cm
2626 : integer, intent(in) :: id
2627 : real(dp), intent(in) :: r_cm
2628 : integer, intent(out) :: ierr
2629 0 : call do_remove_surface_by_radius_cm(id, r_cm, ierr)
2630 0 : end subroutine star_remove_surface_by_radius_cm
2631 :
2632 :
2633 0 : subroutine star_remove_surface_by_mass_fraction_q(id, q, ierr)
2634 0 : use remove_shells, only: do_remove_surface_by_q
2635 : integer, intent(in) :: id
2636 : real(dp), intent(in) :: q
2637 : integer, intent(out) :: ierr
2638 0 : call do_remove_surface_by_q(id, q, ierr)
2639 0 : end subroutine star_remove_surface_by_mass_fraction_q
2640 :
2641 :
2642 0 : subroutine star_remove_surface_by_mass_gm(id, m, ierr)
2643 0 : use remove_shells, only: do_remove_surface_by_mass_gm
2644 : integer, intent(in) :: id
2645 : real(dp), intent(in) :: m
2646 : integer, intent(out) :: ierr
2647 0 : call do_remove_surface_by_mass_gm(id, m, ierr)
2648 0 : end subroutine star_remove_surface_by_mass_gm
2649 :
2650 :
2651 0 : subroutine star_limit_center_logP(id, logP_limit, ierr)
2652 0 : use remove_shells, only: do_limit_center_logP
2653 : integer, intent(in) :: id
2654 : real(dp), intent(in) :: logP_limit
2655 : integer, intent(out) :: ierr
2656 0 : call do_limit_center_logP(id, logP_limit, ierr)
2657 0 : end subroutine star_limit_center_logP
2658 :
2659 :
2660 0 : subroutine star_remove_center_by_logRho(id, logRho_limit, ierr)
2661 0 : use remove_shells, only: do_remove_center_by_logRho
2662 : integer, intent(in) :: id
2663 : real(dp), intent(in) :: logRho_limit
2664 : integer, intent(out) :: ierr
2665 0 : call do_remove_center_by_logRho(id, logRho_limit, ierr)
2666 0 : end subroutine star_remove_center_by_logRho
2667 :
2668 :
2669 0 : subroutine star_remove_fallback(id, ierr)
2670 0 : use remove_shells, only: do_remove_fallback
2671 : integer, intent(in) :: id
2672 : integer, intent(out) :: ierr
2673 0 : call do_remove_fallback(id, ierr)
2674 0 : end subroutine star_remove_fallback
2675 :
2676 :
2677 0 : subroutine smooth_abundances_in_section(id, cnt, nzlo, nzhi, ierr)
2678 : ! purely for cosmetic purposes. doesn't even try to conserve abundances.
2679 0 : use star_utils, only: smooth_abundances
2680 : integer, intent(in) :: id
2681 : integer, intent(in) :: cnt ! make this many passes
2682 : integer, intent(in) :: nzlo, nzhi ! only smooth zones nzlo to nzhi inclusive
2683 : integer, intent(out) :: ierr
2684 : type (star_info), pointer :: s
2685 0 : call star_ptr(id, s, ierr)
2686 0 : if (ierr /= 0) return
2687 0 : call smooth_abundances(s, cnt, nzlo, nzhi, ierr)
2688 0 : end subroutine smooth_abundances_in_section
2689 :
2690 :
2691 0 : subroutine smooth_xa_by_boxcar_mass( &
2692 : id, min_mass, max_mass, boxcar_mass, number_iterations, ierr)
2693 : ! conserves total mass by species
2694 0 : use star_utils, only: do_boxcar_mixing
2695 : integer, intent(in) :: id
2696 : real(dp), intent(in) :: max_mass, min_mass, boxcar_mass ! Msun
2697 : integer, intent(in) :: number_iterations
2698 : integer, intent(out) :: ierr
2699 : type (star_info), pointer :: s
2700 0 : call star_ptr(id, s, ierr)
2701 0 : if (ierr /= 0) return
2702 : call do_boxcar_mixing( &
2703 0 : s, min_mass, max_mass, boxcar_mass, number_iterations, ierr)
2704 0 : end subroutine smooth_xa_by_boxcar_mass
2705 :
2706 :
2707 0 : subroutine smooth_values_by_mass( &
2708 : id, boxcar_mass, number_iterations, val, ierr)
2709 : ! conserves total amount
2710 0 : use mix_info, only: do_smoothing_by_mass
2711 : integer, intent(in) :: id
2712 : real(dp), intent(in) :: boxcar_mass
2713 : integer, intent(in) :: number_iterations
2714 : real(dp), pointer :: val(:)
2715 : integer, intent(out) :: ierr
2716 : type (star_info), pointer :: s
2717 0 : call star_ptr(id, s, ierr)
2718 0 : if (ierr /= 0) return
2719 : call do_smoothing_by_mass( &
2720 0 : s, boxcar_mass, number_iterations, val, ierr)
2721 0 : end subroutine smooth_values_by_mass
2722 :
2723 :
2724 : ! PGSTAR interface
2725 1 : subroutine start_new_run_for_pgstar(s, ierr) ! reset logs
2726 0 : use pgstar
2727 : type (star_info), pointer :: s
2728 : integer, intent(out) :: ierr
2729 1 : call do_start_new_run_for_pgstar(s, ierr)
2730 1 : end subroutine start_new_run_for_pgstar
2731 :
2732 :
2733 0 : subroutine restart_run_for_pgstar(s, ierr)
2734 1 : use pgstar
2735 : type (star_info), pointer :: s
2736 : integer, intent(out) :: ierr
2737 0 : call do_restart_run_for_pgstar(s, ierr)
2738 0 : end subroutine restart_run_for_pgstar
2739 :
2740 :
2741 0 : subroutine read_pgstar_controls(s, ierr)
2742 0 : use pgstar, only: do_read_pgstar_controls
2743 : type (star_info), pointer :: s
2744 : integer, intent(out) :: ierr
2745 0 : call do_read_pgstar_controls(s, 'inlist', ierr)
2746 0 : end subroutine read_pgstar_controls
2747 :
2748 :
2749 0 : subroutine read_pgstar_inlist(s, inlist_fname, ierr)
2750 0 : use pgstar, only: do_read_pgstar_controls
2751 : type (star_info), pointer :: s
2752 : character(*), intent(in) :: inlist_fname
2753 : integer, intent(out) :: ierr
2754 0 : call do_read_pgstar_controls(s, inlist_fname, ierr)
2755 0 : end subroutine read_pgstar_inlist
2756 :
2757 :
2758 0 : subroutine update_pgstar_plots( &
2759 : s, must_write_files, &
2760 : ierr)
2761 0 : use pgstar
2762 : type (star_info), pointer :: s
2763 : logical, intent(in) :: must_write_files
2764 : integer, intent(out) :: ierr
2765 : call do_pgstar_plots( &
2766 : s, must_write_files, &
2767 0 : ierr)
2768 0 : end subroutine update_pgstar_plots
2769 :
2770 :
2771 0 : subroutine create_pgstar_file_name(s, dir, prefix, name)
2772 0 : use pgstar, only: do_create_file_name
2773 : type (star_info), pointer :: s
2774 : character (len=*), intent(in) :: dir, prefix
2775 : character (len=*), intent(out) :: name
2776 0 : call do_create_file_name(s, dir, prefix, name)
2777 0 : end subroutine create_pgstar_file_name
2778 :
2779 :
2780 0 : subroutine pgstar_write_plot_to_file(s, p, filename, ierr)
2781 0 : use star_pgstar, only: pgstar_win_file_data
2782 : use pgstar, only: do_write_plot_to_file
2783 : type (star_info), pointer :: s
2784 : type (pgstar_win_file_data), pointer :: p
2785 : character (len=*), intent(in) :: filename
2786 : integer, intent(out) :: ierr
2787 0 : call do_write_plot_to_file(s, p, filename, ierr)
2788 0 : end subroutine pgstar_write_plot_to_file
2789 :
2790 :
2791 0 : subroutine set_pgstar_xaxis_bounds( &
2792 : s, xaxis_by, win_xmin_in, win_xmax_in, xmargin, &
2793 : xvec, xmin, xmax, xleft, xright, dx, &
2794 : grid_min, grid_max, npts, ierr)
2795 0 : use pgstar, only: do_set_xaxis_bounds
2796 : type (star_info), pointer :: s
2797 : character (len=*), intent(in) :: xaxis_by
2798 : real, intent(in) :: win_xmin_in, win_xmax_in, xmargin
2799 : real, allocatable, dimension(:) :: xvec
2800 : real, intent(out) :: xmin, xmax, xleft, xright, dx
2801 : integer, intent(out) :: grid_min, grid_max, npts
2802 : integer, intent(out) :: ierr
2803 : call do_set_xaxis_bounds( &
2804 : s, xaxis_by, win_xmin_in, win_xmax_in, xmargin, &
2805 : xvec, xmin, xmax, xleft, xright, dx, &
2806 0 : grid_min, grid_max, npts, ierr)
2807 0 : end subroutine set_pgstar_xaxis_bounds
2808 :
2809 :
2810 0 : subroutine show_pgstar_xaxis_by(s,by,ierr)
2811 0 : use pgstar, only: do_show_xaxis_by
2812 : type (star_info), pointer :: s
2813 : character (len=*), intent(in) :: by
2814 : integer, intent(out) :: ierr
2815 0 : call do_show_xaxis_by(s,by,ierr)
2816 0 : end subroutine show_pgstar_xaxis_by
2817 :
2818 :
2819 0 : subroutine show_pgstar_annotations( &
2820 : s, show_annotation1, show_annotation2, show_annotation3)
2821 0 : use pgstar, only: do_show_pgstar_annotations
2822 : type (star_info), pointer :: s
2823 : logical, intent(in) :: &
2824 : show_annotation1, show_annotation2, show_annotation3
2825 : call do_show_pgstar_annotations( &
2826 0 : s, show_annotation1, show_annotation2, show_annotation3)
2827 0 : end subroutine show_pgstar_annotations
2828 :
2829 :
2830 0 : subroutine pgstar_show_box(s, str1, str2)
2831 0 : use pgstar, only: show_box_pgstar
2832 : type (star_info), pointer :: s
2833 : character (len=*), intent(in) :: str1, str2
2834 0 : call show_box_pgstar(s, str1, str2)
2835 0 : end subroutine pgstar_show_box
2836 :
2837 :
2838 0 : subroutine pgstar_show_title(s, title, pad)
2839 0 : use pgstar, only: show_title_pgstar
2840 : type (star_info), pointer :: s
2841 : character (len=*), intent(in) :: title
2842 : real, intent(in) :: pad
2843 : optional pad
2844 : real :: pad_arg
2845 0 : pad_arg = 0
2846 0 : if (present(pad)) pad_arg = pad
2847 0 : call show_title_pgstar(s, title, pad_arg)
2848 0 : end subroutine pgstar_show_title
2849 :
2850 :
2851 0 : subroutine pgstar_show_xaxis_label(s, label, pad)
2852 0 : use pgstar, only: show_xaxis_label_pgstar
2853 : type (star_info), pointer :: s
2854 : character (len=*), intent(in) :: label
2855 : real, intent(in) :: pad
2856 : optional pad
2857 : real :: pad_arg
2858 0 : pad_arg = 0
2859 0 : if (present(pad)) pad_arg = pad
2860 0 : call show_xaxis_label_pgstar(s, label, pad_arg)
2861 0 : end subroutine pgstar_show_xaxis_label
2862 :
2863 :
2864 0 : subroutine pgstar_show_left_yaxis_label(s, label, pad)
2865 0 : use pgstar, only: show_left_yaxis_label_pgstar
2866 : type (star_info), pointer :: s
2867 : character (len=*), intent(in) :: label
2868 : real, intent(in) :: pad
2869 : optional pad
2870 : real :: pad_arg
2871 0 : pad_arg = 0
2872 0 : if (present(pad)) pad_arg = pad
2873 0 : call show_left_yaxis_label_pgstar(s, label, pad_arg)
2874 0 : end subroutine pgstar_show_left_yaxis_label
2875 :
2876 :
2877 0 : subroutine pgstar_show_right_yaxis_label(s, label, pad)
2878 0 : use pgstar, only: show_right_yaxis_label_pgstar
2879 : type (star_info), pointer :: s
2880 : character (len=*), intent(in) :: label
2881 : real, intent(in) :: pad
2882 : optional pad
2883 : real :: pad_arg
2884 0 : pad_arg = 0
2885 0 : if (present(pad)) pad_arg = pad
2886 0 : call show_right_yaxis_label_pgstar(s, label, pad_arg)
2887 0 : end subroutine pgstar_show_right_yaxis_label
2888 :
2889 :
2890 0 : subroutine pgstar_show_left_axis_label_pgmtxt( &
2891 : s, coord, fjust, label, pad)
2892 0 : use pgstar, only: show_left_yaxis_label_pgmtxt_pgstar
2893 : type (star_info), pointer :: s
2894 : character (len=*), intent(in) :: label
2895 : real, intent(in) :: pad, coord, fjust
2896 : optional pad
2897 : real :: pad_arg
2898 0 : pad_arg = 0
2899 : if (present(pad)) pad_arg = pad
2900 : call show_left_yaxis_label_pgmtxt_pgstar( &
2901 0 : s, coord, fjust, label, pad)
2902 0 : end subroutine pgstar_show_left_axis_label_pgmtxt
2903 :
2904 :
2905 0 : subroutine pgstar_show_right_axis_label_pgmtxt( &
2906 : s, coord, fjust, label, pad)
2907 0 : use pgstar, only: show_right_yaxis_label_pgmtxt_pgstar
2908 : type (star_info), pointer :: s
2909 : character (len=*), intent(in) :: label
2910 : real, intent(in) :: pad, coord, fjust
2911 : optional pad
2912 : real :: pad_arg
2913 0 : pad_arg = 0
2914 : if (present(pad)) pad_arg = pad
2915 : call show_right_yaxis_label_pgmtxt_pgstar( &
2916 0 : s, coord, fjust, label, pad)
2917 0 : end subroutine pgstar_show_right_axis_label_pgmtxt
2918 :
2919 :
2920 0 : subroutine pgstar_show_model_number(s)
2921 0 : use pgstar, only: show_model_number_pgstar
2922 : type (star_info), pointer :: s
2923 0 : call show_model_number_pgstar(s)
2924 0 : end subroutine pgstar_show_model_number
2925 :
2926 :
2927 0 : subroutine pgstar_show_age(s)
2928 0 : use pgstar, only: show_age_pgstar
2929 : type (star_info), pointer :: s
2930 0 : call show_age_pgstar(s)
2931 0 : end subroutine pgstar_show_age
2932 :
2933 :
2934 0 : subroutine star_history_specs(s, num, names, specs, report)
2935 0 : use history, only: get_history_specs
2936 : type (star_info), pointer :: s
2937 : integer, intent(in) :: num
2938 : character (len=*), intent(in) :: names(:)
2939 : integer, intent(out) :: specs(:)
2940 : logical, intent(in) :: report
2941 0 : call get_history_specs(s, num, names, specs, report)
2942 0 : end subroutine star_history_specs
2943 :
2944 :
2945 0 : subroutine star_history_values(s, num, specs, &
2946 0 : is_int_value, int_values, values, failed_to_find_value)
2947 0 : use history, only: get_history_values
2948 : type (star_info), pointer :: s
2949 : integer, intent(in) :: num
2950 : integer, intent(in) :: specs(:)
2951 : logical, intent(out) :: is_int_value(:)
2952 : integer, intent(out) :: int_values(:)
2953 : real(dp), intent(inout) :: values(:)
2954 : logical, intent(out) :: failed_to_find_value(:)
2955 : call get_history_values(s, num, specs, &
2956 0 : is_int_value, int_values, values, failed_to_find_value)
2957 0 : end subroutine star_history_values
2958 :
2959 :
2960 0 : integer function star_get_profile_id(s, name)
2961 : ! If star_get_profile_id <0 then it failed to find the column
2962 0 : use profile_getval, only: get_profile_id
2963 : type (star_info), pointer :: s
2964 : character(len=*),intent(in) :: name
2965 0 : star_get_profile_id = get_profile_id(s,name)
2966 0 : end function star_get_profile_id
2967 :
2968 :
2969 0 : real(dp) function star_get_profile_val(s,id,k)
2970 0 : use profile, only: get_profile_val
2971 : type (star_info), pointer :: s
2972 : integer,intent(in) :: id,k
2973 0 : star_get_profile_val = get_profile_val(s,id,k)
2974 0 : end function star_get_profile_val
2975 :
2976 :
2977 0 : real(dp) function star_get_profile_output(s, name, k, ierr)
2978 0 : use profile, only : get_profile_val
2979 : type (star_info), pointer :: s
2980 : character(len=*),intent(in) :: name
2981 : integer,intent(in) :: k
2982 : integer, intent(out), optional :: ierr
2983 : integer :: id
2984 0 : if (present(ierr)) ierr = 0
2985 0 : star_get_profile_output = -HUGE(star_get_profile_output)
2986 0 : id = star_get_profile_id(s, name)
2987 0 : if (id < 0) then
2988 0 : if (present(ierr)) ierr = 1
2989 0 : return
2990 : end if
2991 0 : star_get_profile_output = get_profile_val(s,id,k)
2992 0 : end function star_get_profile_output
2993 :
2994 0 : real(dp) function star_get_profile_output_by_id(id, name, k, ierr_opt)
2995 : integer, intent(in) :: id
2996 : type (star_info), pointer :: s
2997 : character(len=*),intent(in) :: name
2998 : integer,intent(in) :: k
2999 : integer, intent(out), optional :: ierr_opt
3000 : integer :: ierr
3001 0 : star_get_profile_output_by_id = -HUGE(star_get_profile_output_by_id)
3002 0 : call star_ptr(id, s, ierr)
3003 0 : if (present(ierr_opt)) ierr_opt = ierr
3004 0 : if (ierr /= 0) return
3005 0 : star_get_profile_output_by_id = star_get_profile_output(s, name, k, ierr)
3006 0 : if (present(ierr_opt)) ierr_opt = ierr
3007 0 : end function star_get_profile_output_by_id
3008 :
3009 :
3010 0 : logical function star_get1_history_value(s, name, val)
3011 : use history, only: get1_hist_value
3012 : type (star_info), pointer :: s
3013 : character (len=*) :: name
3014 : real(dp), intent(out) :: val
3015 0 : star_get1_history_value = get1_hist_value(s, name, val)
3016 0 : end function star_get1_history_value
3017 :
3018 :
3019 0 : real(dp) function star_get_history_output(s, name, ierr)
3020 : ! If error return -huge(double) and ierr = 1, if provided
3021 0 : use history, only: get_history_specs, get_history_values, get1_hist_value
3022 : type (star_info), pointer :: s
3023 : character(len=*), intent(in) :: name
3024 : integer, intent(out), optional :: ierr
3025 : integer, parameter :: num_rows = 1
3026 0 : real(dp) :: values(num_rows)
3027 : integer :: int_values(num_rows), specs(num_rows)
3028 : logical :: is_int_value(num_rows)
3029 : logical :: failed_to_find_value(num_rows)
3030 0 : if (present(ierr)) ierr = 0
3031 0 : call get_history_specs(s, num_rows, [name], specs, .false.)
3032 : call get_history_values( &
3033 : s, num_rows, specs, &
3034 0 : is_int_value, int_values, values, failed_to_find_value)
3035 0 : if (failed_to_find_value(num_rows)) then
3036 0 : if (.not. get1_hist_value(s, name, values(num_rows))) then
3037 0 : star_get_history_output = -HUGE(star_get_history_output)
3038 0 : if (present(ierr)) ierr = 1
3039 0 : return
3040 : end if
3041 : end if
3042 0 : if (is_int_value(1)) then
3043 0 : star_get_history_output=dble(int_values(num_rows))
3044 : else
3045 0 : star_get_history_output=values(num_rows)
3046 : end if
3047 0 : end function star_get_history_output
3048 :
3049 0 : real(dp) function star_get_history_output_by_id(id, name, ierr_opt)
3050 : integer, intent(in) :: id
3051 : character(len=*),intent(in) :: name
3052 : type(star_info), pointer :: s
3053 : integer, intent(out), optional :: ierr_opt
3054 : integer :: ierr
3055 0 : star_get_history_output_by_id = -HUGE(star_get_history_output_by_id)
3056 0 : call star_ptr(id, s, ierr)
3057 0 : if (present(ierr_opt)) ierr_opt = ierr
3058 0 : if (ierr /= 0) return
3059 0 : star_get_history_output_by_id = star_get_history_output(s, name, ierr)
3060 0 : if (present(ierr_opt)) ierr_opt = ierr
3061 0 : end function star_get_history_output_by_id
3062 :
3063 :
3064 0 : subroutine star_set_mlt_vars(id, nzlo, nzhi, ierr)
3065 : use turb_info, only: set_mlt_vars
3066 : use star_def
3067 : integer, intent(in) :: id ! id for star
3068 : integer, intent(in) :: nzlo, nzhi ! range of cell numbers
3069 : integer, intent(inout) :: ierr
3070 : type (star_info), pointer :: s
3071 0 : call star_ptr(id, s, ierr)
3072 0 : if (ierr /= 0) return
3073 0 : call set_mlt_vars(s, nzlo, nzhi, ierr)
3074 0 : end subroutine star_set_mlt_vars
3075 :
3076 :
3077 0 : subroutine star_mlt_gradT(id, MLT_option, & ! can be useful when creating models
3078 : r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height, &
3079 : iso, XH1, cgrav, m, gradL_composition_term, mixing_length_alpha, &
3080 : mixing_type, gradT, Y_face, conv_vel, D, Gamma, ierr)
3081 0 : use const_def, only: dp
3082 : use turb_support, only: get_gradT
3083 : integer, intent(in) :: id
3084 : character (len=*), intent(in) :: MLT_option
3085 : real(dp), intent(in) :: &
3086 : r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height, &
3087 : XH1, cgrav, m, gradL_composition_term, mixing_length_alpha
3088 : integer, intent(in) :: iso
3089 : real(dp), intent(out) :: gradT, Y_face, conv_vel, D, Gamma
3090 : integer, intent(out) :: mixing_type, ierr
3091 : type (star_info), pointer :: s
3092 0 : call star_ptr(id, s, ierr)
3093 0 : if (ierr /= 0) return
3094 : call get_gradT(s, MLT_option, &
3095 : r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height, &
3096 : iso, XH1, cgrav, m, gradL_composition_term, mixing_length_alpha, &
3097 0 : mixing_type, gradT, Y_face, conv_vel, D, Gamma, ierr)
3098 0 : end subroutine star_mlt_gradT
3099 :
3100 :
3101 0 : subroutine star_mlt_results(id, k, MLT_option, & ! NOTE: k=0 is a valid arg
3102 : r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height, &
3103 : iso, XH1, cgrav, m, gradL_composition_term, mixing_length_alpha, &
3104 : alpha_semiconvection, thermohaline_coeff, &
3105 : mixing_type, gradT, Y_face, conv_vel, D, Gamma, ierr)
3106 0 : use const_def, only: dp
3107 : use auto_diff
3108 : use turb_support, only: Get_results
3109 : integer, intent(in) :: id
3110 : integer, intent(in) :: k
3111 : character (len=*), intent(in) :: MLT_option
3112 : type(auto_diff_real_star_order1), intent(in) :: &
3113 : r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height
3114 : integer, intent(in) :: iso
3115 : real(dp), intent(in) :: &
3116 : XH1, cgrav, m, gradL_composition_term, &
3117 : mixing_length_alpha, alpha_semiconvection, thermohaline_coeff
3118 : integer, intent(out) :: mixing_type
3119 : type(auto_diff_real_star_order1), intent(out) :: &
3120 : gradT, Y_face, conv_vel, D, Gamma
3121 : integer, intent(out) :: ierr
3122 : type(auto_diff_real_star_order1) :: dV
3123 : type (star_info), pointer :: s
3124 0 : call star_ptr(id, s, ierr)
3125 0 : if (ierr /= 0) return
3126 0 : dV = 0d0 ! dV = 1/rho - 1/rho_start and we assume rho = rho_start.
3127 : call Get_results(s, k, MLT_option, &
3128 : r, L, T, P, opacity, rho, dV, chiRho, chiT, Cp, gradr, grada, scale_height, &
3129 : iso, XH1, cgrav, m, gradL_composition_term, mixing_length_alpha, &
3130 : alpha_semiconvection, thermohaline_coeff, &
3131 0 : mixing_type, gradT, Y_face, conv_vel, D, Gamma, ierr)
3132 0 : end subroutine star_mlt_results
3133 :
3134 :
3135 0 : subroutine star_do_garbage_collection(id, ierr)
3136 0 : use init, only: do_garbage_collection
3137 : integer, intent(in) :: id
3138 : integer, intent(inout) :: ierr
3139 : type (star_info), pointer :: s
3140 0 : call star_ptr(id, s, ierr)
3141 0 : if (ierr /= 0) return
3142 0 : call do_garbage_collection(s% job% eosDT_cache_dir, ierr)
3143 0 : if (ierr /= 0) return
3144 0 : end subroutine star_do_garbage_collection
3145 :
3146 :
3147 1 : subroutine star_shutdown_pgstar(id, ierr)
3148 0 : use pgstar, only: shutdown_pgstar
3149 : integer, intent(in) :: id ! id for star
3150 : integer, intent(out) :: ierr
3151 : type (star_info), pointer :: s
3152 : ierr = 0
3153 1 : call star_ptr(id, s, ierr)
3154 1 : if (ierr /= 0) return
3155 1 : call shutdown_pgstar(s)
3156 1 : end subroutine star_shutdown_pgstar
3157 :
3158 :
3159 0 : subroutine star_create_RSP_model(id, ierr)
3160 1 : use init, only: create_RSP_model
3161 : integer, intent(in) :: id
3162 : integer, intent(out) :: ierr
3163 0 : call create_RSP_model(id, ierr)
3164 0 : end subroutine star_create_RSP_model
3165 :
3166 :
3167 0 : subroutine star_create_RSP2_model(id, ierr)
3168 0 : use init, only: create_RSP2_model
3169 : integer, intent(in) :: id
3170 : integer, intent(out) :: ierr
3171 0 : call create_RSP2_model(id, ierr)
3172 0 : end subroutine star_create_RSP2_model
3173 :
3174 :
3175 0 : subroutine star_do1_rsp_build(s,ierr)
3176 : ! call from other_rsp_build_model after changing params.
3177 : ! can change rsp_* params; but cannot change nz or net.
3178 : ! multiple calls are ok to search.
3179 0 : use rsp, only : do1_rsp_build
3180 : type (star_info), pointer :: s
3181 : integer, intent(out) :: ierr
3182 0 : call do1_rsp_build(s,ierr)
3183 0 : end subroutine star_do1_rsp_build
3184 :
3185 :
3186 0 : subroutine rsp_do1_eos_and_kap(s,k,ierr)
3187 0 : use rsp_step, only : do1_eos_and_kap
3188 : type (star_info), pointer :: s
3189 : integer, intent(in) :: k
3190 : integer, intent(out) :: ierr
3191 0 : call do1_eos_and_kap(s,s% nz+1-k,ierr)
3192 0 : end subroutine rsp_do1_eos_and_kap
3193 :
3194 :
3195 0 : integer function check_change_timestep_limit( &
3196 : id, delta_value, lim, hard_lim, i, msg, &
3197 : skip_hard_limit, dt_limit_ratio, relative_excess)
3198 0 : use const_def, only:ln10
3199 : use timestep, only: check_change
3200 : use star_def, only: terminate
3201 : integer, intent(in) :: id
3202 : real(dp), intent(in) :: delta_value, lim, hard_lim
3203 : integer, intent(in) :: i
3204 : character (len=*), intent(in) :: msg
3205 : logical, intent(in) :: skip_hard_limit
3206 : real(dp), intent(inout) :: dt_limit_ratio
3207 : real(dp), intent(out) :: relative_excess
3208 : type (star_info), pointer :: s
3209 : integer :: ierr
3210 : ierr = 0
3211 0 : call star_ptr(id, s, ierr)
3212 0 : if (ierr /= 0) then
3213 0 : check_change_timestep_limit = terminate
3214 : return
3215 : end if
3216 : check_change_timestep_limit = check_change( &
3217 : s, delta_value, lim, hard_lim, i, msg, &
3218 0 : skip_hard_limit, dt_limit_ratio, relative_excess)
3219 0 : end function check_change_timestep_limit
3220 :
3221 :
3222 0 : integer function check_change_integer_timestep_limit( &
3223 : id, limit, hard_limit, value, msg, skip_hard_limit, dt, dt_limit_ratio)
3224 0 : use const_def, only:ln10
3225 : use timestep, only: check_integer_limit
3226 : use star_def, only: terminate
3227 : integer, intent(in) :: id
3228 : integer, intent(in) :: limit, hard_limit, value
3229 : character (len=*), intent(in) :: msg
3230 : logical, intent(in) :: skip_hard_limit
3231 : real(dp), intent(in) :: dt
3232 : real(dp), intent(inout) :: dt_limit_ratio
3233 : type (star_info), pointer :: s
3234 : integer :: ierr
3235 : ierr = 0
3236 0 : call star_ptr(id, s, ierr)
3237 0 : if (ierr /= 0) then
3238 0 : check_change_integer_timestep_limit = terminate
3239 : return
3240 : end if
3241 : check_change_integer_timestep_limit = check_integer_limit( &
3242 0 : s, limit, hard_limit, value, msg, skip_hard_limit, dt, dt_limit_ratio)
3243 0 : end function check_change_integer_timestep_limit
3244 :
3245 :
3246 0 : real(dp) function star_remnant_mass(id)
3247 0 : use star_utils, only: get_remnant_mass
3248 : integer, intent(in) :: id
3249 : type (star_info), pointer :: s
3250 : integer :: ierr
3251 : ierr = 0
3252 0 : call star_ptr(id, s, ierr)
3253 0 : star_remnant_mass = get_remnant_mass(s)
3254 0 : end function star_remnant_mass
3255 :
3256 :
3257 0 : real(dp) function star_ejecta_mass(id)
3258 0 : use star_utils, only: get_ejecta_mass
3259 : integer, intent(in) :: id
3260 : type (star_info), pointer :: s
3261 : integer :: ierr
3262 : ierr = 0
3263 0 : call star_ptr(id, s, ierr)
3264 0 : star_ejecta_mass = get_ejecta_mass(s)
3265 0 : end function star_ejecta_mass
3266 :
3267 :
3268 : ! Returns the next available star id
3269 0 : integer function star_find_next_star_id()
3270 0 : use star_private_def, only : find_next_star_id
3271 0 : star_find_next_star_id = find_next_star_id()
3272 0 : end function star_find_next_star_id
3273 :
3274 :
3275 0 : subroutine star_init_star_handles()
3276 0 : use star_private_def, only: init_star_handles
3277 0 : call init_star_handles()
3278 0 : end subroutine star_init_star_handles
3279 :
3280 :
3281 0 : subroutine star_get_control_namelist(id, name, val, ierr)
3282 0 : use ctrls_io, only: get_control
3283 : integer, intent(in) :: id
3284 : character(len=*),intent(in) :: name
3285 : character(len=*),intent(out) :: val
3286 : integer, intent(out) :: ierr
3287 : type (star_info), pointer :: s
3288 :
3289 : ierr = 0
3290 0 : call star_ptr(id, s, ierr)
3291 0 : if(ierr/=0) return
3292 0 : call get_control(s, name, val, ierr)
3293 :
3294 0 : end subroutine star_get_control_namelist
3295 :
3296 0 : subroutine star_set_control_namelist(id, name, val, ierr)
3297 0 : use ctrls_io, only: set_control
3298 : integer, intent(in) :: id
3299 : character(len=*),intent(in) :: name
3300 : character(len=*),intent(in) :: val
3301 : integer, intent(out) :: ierr
3302 : type (star_info), pointer :: s
3303 :
3304 : ierr = 0
3305 0 : call star_ptr(id, s, ierr)
3306 0 : if(ierr/=0) return
3307 0 : call set_control(s, name, val, ierr)
3308 :
3309 0 : end subroutine star_set_control_namelist
3310 :
3311 :
3312 0 : subroutine star_get_star_job_namelist(id, name, val, ierr)
3313 0 : use star_job_ctrls_io, only: get_star_job
3314 : integer, intent(in) :: id
3315 : character(len=*),intent(in) :: name
3316 : character(len=*),intent(out) :: val
3317 : integer, intent(out) :: ierr
3318 : type (star_info), pointer :: s
3319 :
3320 : ierr = 0
3321 0 : call star_ptr(id, s, ierr)
3322 0 : if(ierr/=0) return
3323 0 : call get_star_job(s, name, val, ierr)
3324 :
3325 0 : end subroutine star_get_star_job_namelist
3326 :
3327 0 : subroutine star_set_star_job_namelist(id, name, val, ierr)
3328 0 : use star_job_ctrls_io, only: set_star_job
3329 : integer, intent(in) :: id
3330 : character(len=*),intent(in) :: name
3331 : character(len=*),intent(in) :: val
3332 : integer, intent(out) :: ierr
3333 : type (star_info), pointer :: s
3334 :
3335 : ierr = 0
3336 0 : call star_ptr(id, s, ierr)
3337 0 : if(ierr/=0) return
3338 0 : call set_star_job(s, name, val, ierr)
3339 :
3340 0 : end subroutine star_set_star_job_namelist
3341 :
3342 : end module star_lib
|
