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