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