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