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