Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2010-2019 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 alloc
21 :
22 : use star_private_def
23 : use const_def, only: ln10
24 : use utils_lib, only: &
25 : fill_with_NaNs, fill_with_NaNs_2D, fill_with_NaNs_3d, set_nan, &
26 : is_bad, mesa_error
27 :
28 : implicit none
29 :
30 : integer, parameter :: do_deallocate = 0
31 : integer, parameter :: do_allocate = 1
32 : integer, parameter :: do_check_size = 2
33 : integer, parameter :: do_remove_from_center = 3
34 : integer, parameter :: do_copy_pointers_and_resize = 4
35 : integer, parameter :: do_reallocate = 5
36 : integer, parameter :: do_fill_arrays_with_NaNs = 6
37 :
38 : logical, parameter :: work_array_debug = .false.
39 : logical, parameter :: work_array_trace = .false.
40 :
41 : logical, parameter :: quad_array_debug = .false.
42 : logical, parameter :: quad_array_trace = .false.
43 :
44 : ! working storage
45 :
46 : type work_array_pointer
47 : real(dp), dimension(:), pointer :: p
48 : end type work_array_pointer
49 : integer, parameter :: num_work_arrays = 250
50 : type (work_array_pointer), target :: &
51 : work_pointers(num_work_arrays)
52 :
53 : type quad_array_pointer
54 : real(qp), dimension(:), pointer :: p
55 : end type quad_array_pointer
56 : integer, parameter :: num_quad_arrays = 250
57 : type (quad_array_pointer), target :: &
58 : quad_pointers(num_quad_arrays)
59 :
60 : type int_work_array_pointer
61 : integer, dimension(:), pointer :: p
62 : end type int_work_array_pointer
63 : integer, parameter :: num_int_work_arrays = 250
64 : type (int_work_array_pointer), target :: &
65 : int_work_pointers(num_int_work_arrays)
66 :
67 : type logical_work_array_pointer
68 : logical, dimension(:), pointer :: p
69 : end type logical_work_array_pointer
70 : integer, parameter :: num_logical_work_arrays = 250
71 : type (logical_work_array_pointer), target :: &
72 : logical_work_pointers(num_logical_work_arrays)
73 :
74 : integer :: num_calls, num_returns
75 : integer :: num_allocs, num_deallocs
76 :
77 : contains
78 :
79 1 : subroutine init_alloc
80 : integer :: i
81 1 : num_calls=0; num_returns=0
82 1 : num_allocs=0; num_deallocs=0
83 251 : do i=1,num_work_arrays
84 251 : nullify(work_pointers(i)%p)
85 : end do
86 251 : do i=1,num_quad_arrays
87 251 : nullify(quad_pointers(i)%p)
88 : end do
89 251 : do i=1,num_int_work_arrays
90 251 : nullify(int_work_pointers(i)%p)
91 : end do
92 251 : do i=1,num_logical_work_arrays
93 251 : nullify(logical_work_pointers(i)%p)
94 : end do
95 1 : end subroutine init_alloc
96 :
97 :
98 0 : subroutine alloc_extras(id, liwork, lwork, ierr)
99 : integer, intent(in) :: liwork, lwork, id
100 : integer, intent(out) :: ierr
101 : type (star_info), pointer :: s
102 :
103 0 : call get_star_ptr(id, s, ierr)
104 0 : if (ierr /= 0) return
105 :
106 0 : if (associated(s% extra_iwork)) deallocate(s% extra_iwork)
107 0 : if (associated(s% extra_iwork_old)) deallocate(s% extra_iwork_old)
108 :
109 0 : if (associated(s% extra_work)) deallocate(s% extra_work)
110 0 : if (associated(s% extra_work_old)) deallocate(s% extra_work_old)
111 :
112 : allocate( &
113 : s% extra_iwork(liwork), s% extra_work(lwork), &
114 : s% extra_iwork_old(liwork), s% extra_work_old(lwork), &
115 0 : stat=ierr)
116 0 : if (ierr == 0) then
117 0 : s% len_extra_iwork = liwork
118 0 : s% len_extra_work = lwork
119 0 : if (s% fill_arrays_with_NaNs) then
120 0 : call fill_with_NaNs(s% extra_work)
121 0 : call fill_with_NaNs(s% extra_work_old)
122 0 : else if (s% zero_when_allocate) then
123 0 : s% extra_work = 0
124 0 : s% extra_work_old = 0
125 : end if
126 : end if
127 :
128 0 : end subroutine alloc_extras
129 :
130 :
131 2 : subroutine dealloc_extras(s)
132 : type (star_info), pointer :: s
133 2 : if (associated(s% extra_iwork)) then
134 0 : deallocate(s% extra_iwork)
135 0 : nullify(s% extra_iwork)
136 : end if
137 2 : if (associated(s% extra_iwork_old)) then
138 0 : deallocate(s% extra_iwork_old)
139 0 : nullify(s% extra_iwork_old)
140 : end if
141 2 : s% len_extra_iwork = 0
142 2 : if (associated(s% extra_work)) then
143 0 : deallocate(s% extra_work)
144 0 : nullify(s% extra_work)
145 : end if
146 2 : if (associated(s% extra_work_old)) then
147 0 : deallocate(s% extra_work_old)
148 0 : nullify(s% extra_work_old)
149 : end if
150 2 : s% len_extra_work = 0
151 2 : end subroutine dealloc_extras
152 :
153 :
154 1 : subroutine update_nvar_allocs(s, nvar_hydro_old, nvar_chem_old, ierr)
155 : use utils_lib, only: realloc_double, realloc_double2, realloc_double3, realloc_quad2
156 : type (star_info), pointer :: s
157 : integer, intent(in) :: nvar_hydro_old, nvar_chem_old
158 : integer, intent(out) :: ierr
159 :
160 : integer :: nvar, nz, species, nvar_chem, nvar_hydro
161 :
162 : include 'formats'
163 :
164 1 : ierr = 0
165 1 : nvar_hydro = s% nvar_hydro
166 1 : nvar_chem = s% nvar_chem
167 1 : species = s% species
168 :
169 2 : if ((nvar_chem_old == nvar_chem) .and. (nvar_hydro_old == nvar_hydro)) return
170 :
171 1 : nvar = nvar_chem + nvar_hydro
172 1 : s% nvar_total = nvar
173 1 : nz = max(s% nz, s% prev_mesh_nz)
174 :
175 1 : if (nvar_chem_old == 0) return
176 :
177 0 : call realloc_double2(s% xh, nvar_hydro, nz + nz_alloc_extra, ierr)
178 0 : if (ierr /= 0) return
179 :
180 : call realloc_double2( &
181 0 : s% xh_old, nvar_hydro, s% nz_old + nz_alloc_extra, ierr)
182 0 : if (ierr /= 0) return
183 :
184 0 : call realloc_double(s% residual_weight1, nvar*(nz + nz_alloc_extra), ierr)
185 0 : if (ierr /= 0) return
186 0 : s% residual_weight(1:nvar,1:nz) => s% residual_weight1(1:nvar*nz)
187 :
188 0 : call realloc_double(s% correction_weight1, nvar*(nz + nz_alloc_extra), ierr)
189 0 : if (ierr /= 0) return
190 0 : s% correction_weight(1:nvar,1:nz) => s% correction_weight1(1:nvar*nz)
191 :
192 0 : call realloc_double(s% solver_dx1, nvar*(nz + nz_alloc_extra), ierr)
193 0 : if (ierr /= 0) return
194 0 : s% solver_dx(1:nvar,1:nz) => s% solver_dx1(1:nvar*nz)
195 :
196 0 : call realloc_double(s% x_scale1, nvar*(nz + nz_alloc_extra), ierr)
197 0 : if (ierr /= 0) return
198 0 : s% x_scale(1:nvar,1:nz) => s% x_scale1(1:nvar*nz)
199 :
200 0 : call realloc_double2(s% xh_start, nvar_hydro, (nz + nz_alloc_extra), ierr)
201 0 : if (ierr /= 0) return
202 :
203 0 : call realloc_double(s% xa_removed, species, ierr)
204 0 : if (ierr /= 0) return
205 :
206 0 : call realloc_double(s% op_mono_factors, species, ierr)
207 0 : if (ierr /= 0) return
208 :
209 : ! do prev_mesh arrays
210 0 : call realloc_double2(s% prev_mesh_xh, nvar_hydro, nz + nz_alloc_extra, ierr)
211 0 : if (ierr /= 0) return
212 0 : call realloc_double2(s% prev_mesh_xa, species, nz + nz_alloc_extra, ierr)
213 0 : if (ierr /= 0) return
214 0 : s% prev_mesh_species_or_nvar_hydro_changed = .true.
215 :
216 : end subroutine update_nvar_allocs
217 :
218 :
219 1 : subroutine free_star_data(id, ierr)
220 : integer, intent(in) :: id
221 : integer, intent(out) :: ierr
222 : type (star_info), pointer :: s
223 1 : call get_star_ptr(id, s, ierr)
224 1 : if (ierr /= 0) return
225 1 : call free_arrays(s)
226 : end subroutine free_star_data
227 :
228 :
229 1 : subroutine free_arrays(s)
230 : use kap_lib, only: free_kap_handle
231 : use eos_lib, only: free_eos_handle
232 : use net_lib, only: free_net_handle
233 : use star_private_def, only: free_star
234 : use star_bcyclic, only: clear_storage
235 : type (star_info), pointer :: s
236 : integer :: ierr
237 :
238 : ! Free handles
239 :
240 1 : call free_net_handle(s% net_handle)
241 1 : s%net_handle = 0
242 :
243 1 : call free_eos_handle(s% eos_handle)
244 1 : s%eos_handle = 0
245 :
246 1 : call free_kap_handle(s% kap_handle)
247 1 : s%kap_handle = 0
248 :
249 : ! Free star_info arrays
250 :
251 1 : call star_info_arrays(s, null(), do_deallocate, ierr)
252 1 : call star_info_old_arrays(s, do_deallocate, ierr)
253 :
254 1 : if (ASSOCIATED(s%xa_removed)) then
255 1 : deallocate(s%xa_removed)
256 1 : nullify(s%xa_removed)
257 : end if
258 1 : if (ASSOCIATED(s%op_mono_factors)) then
259 1 : deallocate(s%op_mono_factors)
260 1 : nullify(s%op_mono_factors)
261 : end if
262 :
263 1 : call dealloc_extras(s)
264 :
265 1 : call free_other(s)
266 :
267 1 : if (ASSOCIATED(s%other_star_info)) then
268 :
269 1 : nullify(s%other_star_info%profile_extra)
270 :
271 1 : call star_info_arrays(s%other_star_info, null(), do_deallocate, ierr)
272 :
273 1 : deallocate(s%other_star_info)
274 :
275 : end if
276 :
277 1 : call dealloc_history(s)
278 :
279 1 : if (ASSOCIATED(s%bcyclic_odd_storage)) call clear_storage(s)
280 :
281 : ! Free the star handle itself
282 :
283 1 : call free_star(s)
284 :
285 1 : end subroutine free_arrays
286 :
287 :
288 1 : subroutine free_other (s)
289 :
290 : type (star_info), pointer :: s
291 :
292 : ! Pointer aliases (do not deallocate, as that's handled elsewhere)
293 :
294 1 : if (ASSOCIATED(s% chem_id)) nullify(s% chem_id)
295 1 : if (ASSOCIATED(s% net_iso)) nullify(s% net_iso)
296 :
297 : ! Misc arrays not handled in star_info_arrays and related
298 : ! routines. (These are "found" by judicious application of
299 : ! valgrind)
300 :
301 1 : if (ASSOCIATED(s% conv_bdy_q)) deallocate(s% conv_bdy_q)
302 1 : if (ASSOCIATED(s% conv_bdy_loc)) deallocate(s% conv_bdy_loc)
303 1 : if (ASSOCIATED(s% top_conv_bdy)) deallocate(s% top_conv_bdy)
304 1 : if (ASSOCIATED(s% burn_h_conv_region)) deallocate(s% burn_h_conv_region)
305 1 : if (ASSOCIATED(s% burn_he_conv_region)) deallocate(s% burn_he_conv_region)
306 1 : if (ASSOCIATED(s% burn_z_conv_region)) deallocate(s% burn_z_conv_region)
307 :
308 1 : if (ASSOCIATED(s% prev_mesh_xa)) deallocate(s% prev_mesh_xa)
309 1 : if (ASSOCIATED(s% prev_mesh_xh)) deallocate(s% prev_mesh_xh)
310 1 : if (ASSOCIATED(s% prev_mesh_j_rot)) deallocate(s% prev_mesh_j_rot)
311 1 : if (ASSOCIATED(s% prev_mesh_omega)) deallocate(s% prev_mesh_omega)
312 1 : if (ASSOCIATED(s% prev_mesh_dq)) deallocate(s% prev_mesh_dq)
313 :
314 1 : if (ASSOCIATED(s% mix_bdy_q)) deallocate(s% mix_bdy_q)
315 1 : if (ASSOCIATED(s% mix_bdy_loc)) deallocate(s% mix_bdy_loc)
316 1 : if (ASSOCIATED(s% top_mix_bdy)) deallocate(s% top_mix_bdy)
317 1 : if (ASSOCIATED(s% burn_h_mix_region)) deallocate(s% burn_h_mix_region)
318 1 : if (ASSOCIATED(s% burn_he_mix_region)) deallocate(s% burn_he_mix_region)
319 1 : if (ASSOCIATED(s% burn_z_mix_region)) deallocate(s% burn_z_mix_region)
320 :
321 1 : if (ASSOCIATED(s% rate_factors)) deallocate(s% rate_factors)
322 :
323 1 : if (ASSOCIATED(s% nameofvar)) deallocate(s% nameofvar)
324 1 : if (ASSOCIATED(s% nameofequ)) deallocate(s% nameofequ)
325 :
326 1 : if (ASSOCIATED(s% solver_work)) deallocate(s% solver_work)
327 1 : if (ASSOCIATED(s% solver_iwork)) deallocate(s% solver_iwork)
328 :
329 1 : if (ASSOCIATED(s% AF1)) deallocate(s% AF1)
330 :
331 1 : end subroutine free_other
332 :
333 :
334 11 : subroutine check_sizes(s, ierr)
335 : type (star_info), pointer :: s
336 : integer, intent(out) :: ierr
337 : type (star_info), pointer :: c => null()
338 11 : call star_info_arrays(s, c, do_check_size, ierr)
339 11 : if (ierr /= 0) then
340 0 : write(*,*) 'check_sizes failed for s'
341 0 : return
342 : end if
343 11 : if (s% generations <= 1) return
344 11 : call star_info_old_arrays(s, do_check_size, ierr)
345 11 : if (ierr /= 0) then
346 0 : write(*,*) 'check_sizes failed for s old'
347 0 : return
348 : end if
349 : end subroutine check_sizes
350 :
351 :
352 0 : subroutine alloc_star_info_old_arrays(s, ierr)
353 : type (star_info), pointer :: s
354 : integer, intent(out) :: ierr
355 0 : call star_info_old_arrays(s, do_allocate, ierr)
356 0 : end subroutine alloc_star_info_old_arrays
357 :
358 :
359 84 : subroutine star_info_old_arrays(s, action, ierr)
360 : type (star_info), pointer :: s
361 : integer, intent(in) :: action
362 : integer, intent(out) :: ierr
363 :
364 : integer :: nz, species, nvar_hydro
365 :
366 : include 'formats'
367 :
368 12 : nz = s% nz_old
369 12 : nvar_hydro = s% nvar_hydro
370 12 : species = s% species
371 : ierr = -1
372 12 : call do2D(s, s% xh_old, nvar_hydro, nz, action, ierr)
373 12 : if (failed('xh_old')) return
374 12 : call do2D(s, s% xa_old, species, nz, action, ierr)
375 12 : if (failed('xa_old')) return
376 12 : call do1D(s, s% q_old, nz, action, ierr)
377 12 : if (failed('q_old')) return
378 12 : call do1D(s, s% dq_old, nz, action, ierr)
379 12 : if (failed('dq_old')) return
380 12 : call do1D(s, s% mlt_vc_old, nz, action, ierr)
381 12 : if (failed('mlt_vc_old')) return
382 12 : call do1D(s, s% omega_old, nz, action, ierr)
383 12 : if (failed('omega_old')) return
384 12 : call do1D(s, s% j_rot_old, nz, action, ierr)
385 12 : if (failed('j_rot_old')) return
386 12 : ierr = 0
387 :
388 : contains
389 :
390 84 : logical function failed(str)
391 : character (len=*), intent(in) :: str
392 84 : failed = .false.
393 84 : if (ierr == 0) return
394 0 : write(*,*) 'star_info_old_arrays failed for ' // trim(str)
395 0 : failed = .true.
396 0 : end function failed
397 :
398 : end subroutine star_info_old_arrays
399 :
400 :
401 0 : subroutine free_star_info_arrays(s)
402 : type (star_info), pointer :: s
403 : integer :: ierr
404 : type (star_info), pointer :: c => null()
405 0 : call star_info_arrays(s, c, do_deallocate, ierr)
406 0 : if (ierr /= 0) write(*,*) 'free_star_info_arrays failed'
407 0 : end subroutine free_star_info_arrays
408 :
409 :
410 1 : subroutine allocate_star_info_arrays(s, ierr)
411 : type (star_info), pointer :: s
412 : integer, intent(out) :: ierr
413 : type (star_info), pointer :: c => null()
414 1 : call star_info_arrays(s, c, do_allocate, ierr)
415 1 : if (ierr /= 0) write(*,*) 'allocate_star_info_arrays failed'
416 1 : end subroutine allocate_star_info_arrays
417 :
418 :
419 0 : subroutine prune_star_info_arrays(s, ierr)
420 : type (star_info), pointer :: s
421 : integer, intent(out) :: ierr
422 : type (star_info), pointer :: c => null()
423 0 : call star_info_arrays(s, c, do_remove_from_center, ierr)
424 0 : if (ierr /= 0) write(*,*) 'prune_star_info_arrays failed'
425 0 : end subroutine prune_star_info_arrays
426 :
427 :
428 10 : subroutine resize_star_info_arrays(s, c, ierr)
429 : type (star_info), pointer :: s, c
430 : integer, intent(out) :: ierr
431 10 : call star_info_arrays(s, c, do_copy_pointers_and_resize, ierr)
432 10 : if (ierr /= 0) write(*,*) 'resize_star_info_arrays failed'
433 10 : end subroutine resize_star_info_arrays
434 :
435 :
436 0 : subroutine reallocate_star_info_arrays(s, ierr)
437 : type (star_info), pointer :: s
438 : integer, intent(out) :: ierr
439 0 : call star_info_arrays(s, null(), do_reallocate, ierr)
440 0 : if (ierr /= 0) write(*,*) 'reallocate_star_info_arrays failed'
441 0 : end subroutine reallocate_star_info_arrays
442 :
443 :
444 0 : subroutine fill_star_info_arrays_with_NaNs(s, ierr)
445 : type (star_info), pointer :: s
446 : integer, intent(out) :: ierr
447 0 : call star_info_arrays(s, null(), do_fill_arrays_with_NaNs, ierr)
448 0 : if (ierr /= 0) write(*,*) 'fill_star_info_arrays_with_NaNs failed'
449 0 : s% need_to_setvars = .true.
450 0 : end subroutine fill_star_info_arrays_with_NaNs
451 :
452 :
453 24 : subroutine star_info_arrays(s, c_in, action_in, ierr)
454 : use eos_def, only:num_eos_basic_results, num_eos_d_dxa_results
455 : use rates_def, only: num_rvs
456 : use chem_def, only: num_categories
457 : use const_def, only: standard_cgrav
458 : type (star_info), pointer :: s, c_in
459 : integer, intent(in) :: action_in
460 : integer, intent(out) :: ierr
461 :
462 : integer :: nz, species, num_reactions, nvar, nvar_hydro, nvar_chem, sz_new, action
463 : type (star_info), pointer :: c
464 : character (len=128) :: null_str
465 :
466 : include 'formats'
467 :
468 24 : ierr = 0
469 24 : null_str = '' ! avoid bogus compiler warnings 'array subscript 1 is above array bounds'
470 :
471 :
472 24 : species = s% species
473 24 : num_reactions = s% num_reactions
474 24 : nvar = s% nvar_total
475 24 : nvar_hydro = s% nvar_hydro
476 24 : nvar_chem = s% nvar_chem
477 :
478 24 : c => s
479 24 : action = action_in
480 24 : if (action == do_check_size) then
481 11 : nz = s% nz
482 11 : sz_new = nz
483 : else
484 13 : nz = max(s% prev_mesh_nz, s% nz)
485 13 : sz_new = nz + nz_alloc_extra
486 : end if
487 :
488 24 : if (action == do_copy_pointers_and_resize) then
489 10 : if (associated(c_in)) then
490 : c => c_in
491 : else ! nothing to copy, so switch to allocate
492 1 : action = do_allocate
493 : end if
494 : end if
495 :
496 : do ! just so can exit on failure
497 :
498 24 : if (action /= do_fill_arrays_with_NaNs) then
499 : ! these arrays must not be filled with NaNs
500 : ! because they contain the inputs to the step
501 24 : call do2(s% xh, c% xh, nvar_hydro, 'xh')
502 24 : if (failed('xh')) exit
503 24 : call do2(s% xa, c% xa, species, 'xa')
504 24 : if (failed('xa')) then
505 0 : write(*,2) 'species', species
506 0 : write(*,2) 'size(s% xa,dim=1)', size(s% xa,dim=1)
507 0 : write(*,2) 's% nz', s% nz
508 0 : write(*,2) 's% prev_mesh_nz', s% prev_mesh_nz
509 0 : write(*,2) 'size(s% xa,dim=2)', size(s% xa,dim=2)
510 0 : call mesa_error(__FILE__,__LINE__,'star_info_arrays')
511 0 : exit
512 : end if
513 24 : call do1(s% dq, c% dq)
514 24 : if (failed('dq')) exit
515 24 : call do1(s% omega, c% omega)
516 24 : if (failed('omega')) exit
517 24 : call do1(s% j_rot, c% j_rot)
518 24 : if (failed('j_rot')) exit
519 24 : call do1(s% mlt_vc, c% mlt_vc)
520 24 : if (failed('mlt_vc')) exit
521 24 : call do1(s% conv_vel, c% conv_vel)
522 24 : if (failed('conv_vel')) exit
523 : end if
524 :
525 24 : call do1(s% q, c% q)
526 24 : if (failed('q')) exit
527 24 : call do1(s% m, c% m)
528 24 : if (failed('m')) exit
529 24 : call do1(s% dm, c% dm)
530 24 : if (failed('dm')) exit
531 24 : call do1(s% dm_bar, c% dm_bar)
532 24 : if (failed('dm_bar')) exit
533 :
534 24 : call do1(s% am_nu_rot, c% am_nu_rot)
535 24 : if (failed('am_nu_rot')) exit
536 24 : call do1(s% D_omega, c% D_omega)
537 24 : if (failed('D_omega')) exit
538 24 : call do1_ad(s% fp_rot, c% fp_rot)
539 24 : if (failed('fp_rot')) exit
540 24 : call do1_ad(s% ft_rot, c% ft_rot)
541 24 : if (failed('ft_rot')) exit
542 24 : call do1(s% am_nu_non_rot, c% am_nu_non_rot)
543 24 : if (failed('am_nu_non_rot')) exit
544 24 : call do1(s% am_nu_omega, c% am_nu_omega)
545 24 : if (failed('am_nu_omega')) exit
546 24 : call do1(s% am_nu_j, c% am_nu_j)
547 24 : if (failed('am_nu_j')) exit
548 24 : call do1(s% am_sig_omega, c% am_sig_omega)
549 24 : if (failed('am_sig_omega')) exit
550 24 : call do1(s% am_sig_j, c% am_sig_j)
551 24 : if (failed('am_sig_j')) exit
552 24 : call do1_ad(s% i_rot, c% i_rot)
553 24 : if (failed('i_rot')) exit
554 24 : call do1(s% w_div_w_crit_roche, c% w_div_w_crit_roche)
555 24 : if (failed('w_div_w_crit_roche')) exit
556 24 : call do1_ad(s% j_flux, c% j_flux)
557 24 : if (failed('j_flux')) exit
558 :
559 24 : call do2(s% xh_start, c% xh_start, nvar_hydro, 'xh_start')
560 24 : if (failed('xh_start')) exit
561 :
562 24 : call do1(s% r_polar, c% r_polar)
563 24 : if (failed('r_polar')) exit
564 24 : call do1(s% r_equatorial, c% r_equatorial)
565 24 : if (failed('r_equatorial')) exit
566 :
567 24 : call do1(s% lnd, c% lnd)
568 24 : if (failed('lnd')) exit
569 24 : call do1(s% lnT, c% lnT)
570 24 : if (failed('lnT')) exit
571 24 : call do1(s% lnR, c% lnR)
572 24 : if (failed('lnR')) exit
573 24 : call do1(s% RSP_Et, c% RSP_Et)
574 24 : if (failed('RSP_Et')) exit
575 24 : call do1(s% L, c% L)
576 24 : if (failed('L')) exit
577 24 : call do1(s% v, c% v)
578 24 : if (failed('v')) exit
579 24 : call do1(s% u, c% u)
580 24 : if (failed('u')) exit
581 24 : call do1(s% alpha_RTI, c% alpha_RTI)
582 24 : if (failed('alpha_RTI')) exit
583 24 : call do1(s% w, c% w)
584 24 : if (failed('w')) exit
585 24 : call do1(s% w_start, c% w_start)
586 24 : if (failed('w_start')) exit
587 24 : call do1(s% Hp_face_start, c% Hp_face_start)
588 24 : if (failed('Hp_face_start')) exit
589 :
590 24 : call do1(s% dxh_lnR, c% dxh_lnR)
591 24 : if (failed('dxh_lnR')) exit
592 24 : call do1(s% dxh_lnd, c% dxh_lnd)
593 24 : if (failed('dxh_lnd')) exit
594 24 : call do1(s% dxh_lnT, c% dxh_lnT)
595 24 : if (failed('dxh_lnT')) exit
596 24 : call do1(s% dxh_v, c% dxh_v)
597 24 : if (failed('dxh_v')) exit
598 24 : call do1(s% dxh_u, c% dxh_u)
599 24 : if (failed('dxh_u')) exit
600 24 : call do1(s% dxh_alpha_RTI, c% dxh_alpha_RTI)
601 24 : if (failed('dxh_alpha_RTI')) exit
602 :
603 24 : call do1(s% dudt_RTI, c% dudt_RTI)
604 24 : if (failed('dudt_RTI')) exit
605 24 : call do1(s% dedt_RTI, c% dedt_RTI)
606 24 : if (failed('dedt_RTI')) exit
607 :
608 24 : call do1(s% T, c% T)
609 24 : if (failed('T')) exit
610 24 : call do1(s% rho, c% rho)
611 24 : if (failed('rho')) exit
612 24 : call do1(s% r, c% r)
613 24 : if (failed('r')) exit
614 :
615 24 : call do1(s% rmid, c% rmid)
616 24 : if (failed('rmid')) exit
617 :
618 24 : call do1(s% X, c% X)
619 24 : if (failed('X')) exit
620 24 : call do1(s% Y, c% Y)
621 24 : if (failed('Y')) exit
622 24 : call do1(s% Z, c% Z)
623 24 : if (failed('Z')) exit
624 24 : call do1(s% abar, c% abar)
625 24 : if (failed('abar')) exit
626 24 : call do1(s% zbar, c% zbar)
627 24 : if (failed('zbar')) exit
628 24 : call do1(s% z2bar, c% z2bar)
629 24 : if (failed('z2bar')) exit
630 24 : call do1(s% z53bar, c% z53bar)
631 24 : if (failed('z53bar')) exit
632 24 : call do1(s% ye, c% ye)
633 24 : if (failed('ye')) exit
634 :
635 24 : call do1(s% mass_correction, c% mass_correction)
636 24 : if (failed('mass_correction')) exit
637 24 : call do1(s% mass_correction_start, c% mass_correction_start)
638 24 : if (failed('mass_correction_start')) exit
639 24 : call do1(s% m_grav, c% m_grav)
640 24 : if (failed('m_grav')) exit
641 24 : call do1(s% m_grav_start, c% m_grav_start)
642 24 : if (failed('m_grav_start')) exit
643 :
644 24 : call do1(s% Peos, c% Peos)
645 24 : if (failed('Peos')) exit
646 24 : call do1(s% lnPeos, c% lnPeos)
647 24 : if (failed('lnPeos')) exit
648 24 : call do1(s% lnPgas, c% lnPgas)
649 24 : if (failed('lnPgas')) exit
650 24 : call do1(s% Pgas, c% Pgas)
651 24 : if (failed('Pgas')) exit
652 24 : call do1(s% Prad, c% Prad)
653 24 : if (failed('Prad')) exit
654 24 : call do1(s% energy, c% energy)
655 24 : if (failed('energy')) exit
656 24 : call do1(s% egas, c% egas)
657 24 : if (failed('egas')) exit
658 24 : call do1(s% erad, c% erad)
659 24 : if (failed('erad')) exit
660 24 : call do1(s% lnE, c% lnE)
661 24 : if (failed('lnE')) exit
662 24 : call do1(s% grada, c% grada)
663 24 : if (failed('grada')) exit
664 24 : call do1(s% dE_dRho, c% dE_dRho)
665 24 : if (failed('dE_dRho')) exit
666 24 : call do1(s% Cv, c% Cv)
667 24 : if (failed('Cv')) exit
668 24 : call do1(s% Cp, c% Cp)
669 24 : if (failed('Cp')) exit
670 24 : call do1(s% lnS, c% lnS)
671 24 : if (failed('lnS')) exit
672 24 : call do1(s% gamma1, c% gamma1)
673 24 : if (failed('gamma1')) exit
674 24 : call do1(s% gamma3, c% gamma3)
675 24 : if (failed('gamma3')) exit
676 24 : call do1(s% eta, c% eta)
677 24 : if (failed('eta')) exit
678 24 : call do1(s% gam, c% gam)
679 24 : if (failed('gam')) exit
680 24 : call do1(s% mu, c% mu)
681 24 : if (failed('mu')) exit
682 24 : call do1(s% lnfree_e, c% lnfree_e)
683 24 : if (failed('lnfree_e')) exit
684 :
685 24 : call do1(s% phase, c% phase)
686 24 : if (failed('phase')) exit
687 24 : call do1(s% latent_ddlnT, c% latent_ddlnT)
688 24 : if (failed('latent_ddlnT')) exit
689 24 : call do1(s% latent_ddlnRho, c% latent_ddlnRho)
690 24 : if (failed('latent_ddlnRho')) exit
691 :
692 24 : call do1(s% chiRho, c% chiRho)
693 24 : if (failed('chiRho')) exit
694 24 : call do1(s% chiT, c% chiT)
695 24 : if (failed('chiT')) exit
696 :
697 24 : call do1(s% eos_frac_OPAL_SCVH, c% eos_frac_OPAL_SCVH)
698 24 : if (failed('eos_frac_OPAL_SCVH')) exit
699 24 : call do1(s% eos_frac_HELM, c% eos_frac_HELM)
700 24 : if (failed('eos_frac_HELM')) exit
701 24 : call do1(s% eos_frac_Skye, c% eos_frac_Skye)
702 24 : if (failed('eos_frac_Skye')) exit
703 24 : call do1(s% eos_frac_PC, c% eos_frac_PC)
704 24 : if (failed('eos_frac_PC')) exit
705 24 : call do1(s% eos_frac_FreeEOS, c% eos_frac_FreeEOS)
706 24 : if (failed('eos_frac_FreeEOS')) exit
707 24 : call do1(s% eos_frac_CMS, c% eos_frac_CMS)
708 24 : if (failed('eos_frac_CMS')) exit
709 24 : call do1(s% eos_frac_ideal, c% eos_frac_ideal)
710 24 : if (failed('eos_frac_ideal')) exit
711 :
712 24 : call do1(s% QQ, c% QQ)
713 24 : if (failed('QQ')) exit
714 24 : call do2(s% d_eos_dlnd, c% d_eos_dlnd, num_eos_basic_results, 'd_eos_dlnd')
715 24 : if (failed('d_eos_dlnd')) exit
716 24 : call do2(s% d_eos_dlnT, c% d_eos_dlnT, num_eos_basic_results, 'd_eos_dlnT')
717 24 : if (failed('d_eos_dlnT')) exit
718 24 : call do3(s% d_eos_dxa, c% d_eos_dxa, num_eos_d_dxa_results, species)
719 24 : if (failed('d_eos_dxa')) exit
720 :
721 24 : call do1(s% chiRho_for_partials, c% chiRho_for_partials)
722 24 : if (failed('chiRho_for_partials')) exit
723 24 : call do1(s% chiT_for_partials, c% chiT_for_partials)
724 24 : if (failed('chiT_for_partials')) exit
725 24 : call do1(s% dE_dRho_for_partials, c% dE_dRho_for_partials)
726 24 : if (failed('dE_dRho_for_partials')) exit
727 24 : call do1(s% Cv_for_partials, c% Cv_for_partials)
728 24 : if (failed('Cv_for_partials')) exit
729 24 : call do1(s% dS_dRho_for_partials, c% dS_dRho_for_partials)
730 24 : if (failed('dS_dRho_for_partials')) exit
731 24 : call do1(s% dS_dT_for_partials, c% dS_dT_for_partials)
732 24 : if (failed('dS_dT_for_partials')) exit
733 24 : call do2(s% dlnE_dxa_for_partials, c% dlnE_dxa_for_partials, species, null_str)
734 24 : if (failed('dlnE_dxa_for_partials')) exit
735 24 : call do2(s% dlnPeos_dxa_for_partials, c% dlnPeos_dxa_for_partials, species, null_str)
736 24 : if (failed('dlnPeos_dxa_for_partials')) exit
737 :
738 : ! other model variables
739 24 : call do1(s% csound, c% csound)
740 24 : if (failed('csound')) exit
741 24 : call do1(s% csound_face, c% csound_face)
742 24 : if (failed('csound_face')) exit
743 :
744 24 : call do1(s% rho_face, c% rho_face)
745 24 : if (failed('rho_face')) exit
746 :
747 24 : call do1(s% scale_height, c% scale_height)
748 24 : if (failed('scale_height')) exit
749 24 : call do1(s% v_div_csound, c% v_div_csound)
750 24 : if (failed('v_div_csound')) exit
751 24 : call do1(s% entropy, c% entropy)
752 24 : if (failed('entropy')) exit
753 24 : call do1(s% grav, c% grav)
754 24 : if (failed('grav')) exit
755 24 : call do1(s% tau, c% tau)
756 24 : if (failed('tau')) exit
757 24 : call do1(s% dr_div_csound, c% dr_div_csound)
758 24 : if (failed('dr_div_csound')) exit
759 :
760 24 : call do1(s% flux_limit_R, c% flux_limit_R)
761 24 : if (failed('flux_limit_R')) exit
762 24 : call do1(s% flux_limit_lambda, c% flux_limit_lambda)
763 24 : if (failed('flux_limit_lambda')) exit
764 :
765 24 : call do1(s% ergs_error, c% ergs_error)
766 24 : if (failed('ergs_error')) exit
767 24 : call do1(s% gradr_factor, c% gradr_factor)
768 24 : if (failed('gradr_factor')) exit
769 24 : call do1(s% adjust_mlt_gradT_fraction, c% adjust_mlt_gradT_fraction)
770 24 : if (failed('adjust_mlt_gradT_fraction')) exit
771 24 : call do1(s% gradT_excess_effect, c% gradT_excess_effect)
772 24 : if (failed('gradT_excess_effect')) exit
773 24 : call do1(s% superad_reduction_factor, c% superad_reduction_factor)
774 24 : if (failed('superad_reduction_factor')) exit
775 :
776 24 : call do1(s% domega_dlnR, c% domega_dlnR)
777 24 : if (failed('domega_dlnR')) exit
778 24 : call do1(s% richardson_number, c% richardson_number)
779 24 : if (failed('richardson_number')) exit
780 :
781 24 : call do1(s% D_mix_rotation, c% D_mix_rotation)
782 24 : if (failed('D_mix_rotation')) exit
783 24 : call do1(s% D_mix_non_rotation, c% D_mix_non_rotation)
784 24 : if (failed('D_mix_non_rotation')) exit
785 24 : call do1(s% D_visc, c% D_visc)
786 24 : if (failed('D_visc')) exit
787 24 : call do1(s% D_DSI, c% D_DSI)
788 24 : if (failed('D_DSI')) exit
789 24 : call do1(s% D_SH, c% D_SH)
790 24 : if (failed('D_SH')) exit
791 24 : call do1(s% D_SSI, c% D_SSI)
792 24 : if (failed('D_SSI')) exit
793 24 : call do1(s% D_ES, c% D_ES)
794 24 : if (failed('D_ES')) exit
795 24 : call do1(s% D_GSF, c% D_GSF)
796 24 : if (failed('D_GSF')) exit
797 :
798 24 : call do1(s% D_ST, c% D_ST)
799 24 : if (failed('D_ST')) exit
800 24 : call do1(s% nu_ST, c% nu_ST)
801 24 : if (failed('nu_ST')) exit
802 24 : call do1(s% omega_shear, c% omega_shear)
803 24 : if (failed('omega_shear')) exit
804 :
805 24 : call do1(s% dynamo_B_r, c% dynamo_B_r)
806 24 : if (failed('dynamo_B_r')) exit
807 24 : call do1(s% dynamo_B_phi, c% dynamo_B_phi)
808 24 : if (failed('dynamo_B_phi')) exit
809 :
810 : !for ST time smoothing
811 24 : call do1(s% D_ST_start, c% D_ST_start)
812 24 : if (failed('D_ST_start')) exit
813 24 : call do1(s% nu_ST_start, c% nu_ST_start)
814 24 : if (failed('nu_ST_start')) exit
815 :
816 24 : call do1(s% opacity, c% opacity)
817 24 : if (failed('opacity')) exit
818 24 : call do1(s% d_opacity_dlnd, c% d_opacity_dlnd)
819 24 : if (failed('d_opacity_dlnd')) exit
820 24 : call do1(s% d_opacity_dlnT, c% d_opacity_dlnT)
821 24 : if (failed('d_opacity_dlnT')) exit
822 24 : call do1(s% kap_frac_lowT, c% kap_frac_lowT)
823 24 : if (failed('kap_frac_lowT')) exit
824 24 : call do1(s% kap_frac_highT, c% kap_frac_highT)
825 24 : if (failed('kap_frac_highT')) exit
826 24 : call do1(s% kap_frac_Type2, c% kap_frac_Type2)
827 24 : if (failed('kap_frac_Type2')) exit
828 24 : call do1(s% kap_frac_Compton, c% kap_frac_Compton)
829 24 : if (failed('kap_frac_Compton')) exit
830 24 : call do1(s% kap_frac_op_mono, c% kap_frac_op_mono)
831 24 : if (failed('kap_frac_op_mono')) exit
832 :
833 24 : call do1(s% eps_nuc, c% eps_nuc)
834 24 : if (failed('eps_nuc')) exit
835 24 : call do1(s% d_epsnuc_dlnd, c% d_epsnuc_dlnd)
836 24 : if (failed('d_epsnuc_dlnd')) exit
837 24 : call do1(s% d_epsnuc_dlnT, c% d_epsnuc_dlnT)
838 24 : if (failed('d_epsnuc_dlnT')) exit
839 24 : call do2(s% d_epsnuc_dx, c% d_epsnuc_dx, species, null_str)
840 24 : if (failed('d_epsnuc_dx')) exit
841 :
842 24 : call do1(s% eps_nuc_neu_total, c% eps_nuc_neu_total)
843 24 : if (failed('eps_nuc_neu_total')) exit
844 :
845 24 : call do2(s% raw_rate, c% raw_rate, num_reactions, null_str)
846 24 : if (failed('raw_rates')) exit
847 24 : call do2(s% screened_rate, c% screened_rate, num_reactions, null_str)
848 24 : if (failed('screened_rates')) exit
849 24 : call do2(s% eps_nuc_rate, c% eps_nuc_rate, num_reactions, null_str)
850 24 : if (failed('eps_nuc_rates')) exit
851 24 : call do2(s% eps_neu_rate, c% eps_neu_rate, num_reactions, null_str)
852 24 : if (failed('eps_neu_rates')) exit
853 :
854 24 : call do2(s% dxdt_nuc, c% dxdt_nuc, species, null_str)
855 24 : if (failed('dxdt_nuc')) exit
856 24 : call do2(s% d_dxdt_nuc_dRho, c% d_dxdt_nuc_dRho, species, null_str)
857 24 : if (failed('d_dxdt_nuc_dRho')) exit
858 24 : call do2(s% d_dxdt_nuc_dT, c% d_dxdt_nuc_dT, species, null_str)
859 24 : if (failed('d_dxdt_nuc_dT')) exit
860 24 : call do3(s% d_dxdt_nuc_dx, c% d_dxdt_nuc_dx, species, species)
861 24 : if (failed('d_dxdt_nuc_dx')) exit
862 :
863 24 : call do2(s% dxdt_mix, c% dxdt_mix, species, null_str)
864 24 : if (failed('dxdt_mix')) exit
865 24 : call do1(s% d_dxdt_mix_dxp1, c% d_dxdt_mix_dxp1)
866 24 : if (failed('d_dxdt_mix_dRho')) exit
867 24 : call do1(s% d_dxdt_mix_dx00, c% d_dxdt_mix_dx00)
868 24 : if (failed('d_dxdt_mix_dx00')) exit
869 24 : call do1(s% d_dxdt_mix_dxm1, c% d_dxdt_mix_dxm1)
870 24 : if (failed('d_dxdt_mix_dxm1')) exit
871 :
872 24 : if (action /= do_check_size) then
873 13 : call do2(s% eps_nuc_categories, c% eps_nuc_categories, num_categories, null_str)
874 13 : if (failed('eps_nuc_categories')) exit
875 13 : call do2(s% luminosity_by_category, c% luminosity_by_category, num_categories, null_str)
876 13 : if (failed('luminosity_by_category')) exit
877 : call do2(s% luminosity_by_category_start, &
878 13 : c% luminosity_by_category_start, num_categories, null_str)
879 13 : if (failed('luminosity_by_category_start')) exit
880 13 : call do2(s% L_nuc_by_category, c% L_nuc_by_category, num_categories, null_str)
881 13 : if (failed('L_nuc_by_category')) exit
882 : end if
883 :
884 24 : call do2(s% diffusion_D_self, c% diffusion_D_self, species, null_str)
885 24 : if (failed('diffusion_D_self')) exit
886 24 : call do2(s% extra_diffusion_factor, c% extra_diffusion_factor, species, null_str)
887 24 : if (failed('extra_diffusion_factor')) exit
888 24 : call do2(s% edv, c% edv, species, null_str)
889 24 : if (failed('edv')) exit
890 24 : call do2(s% v_rad, c% v_rad, species, null_str)
891 24 : if (failed('v_rad')) exit
892 24 : call do2(s% g_rad, c% g_rad, species, null_str)
893 24 : if (failed('g_rad')) exit
894 24 : call do2(s% typical_charge, c% typical_charge, species, null_str)
895 24 : if (failed('typical_charge')) exit
896 24 : call do2(s% diffusion_dX, c% diffusion_dX, species, null_str)
897 24 : if (failed('diffusion_dX')) exit
898 24 : call do1(s% E_field, c% E_field)
899 24 : if (failed('E_field')) exit
900 24 : call do1(s% eps_WD_sedimentation, c% eps_WD_sedimentation)
901 24 : if (failed('eps_WD_sedimentation')) exit
902 24 : call do1(s% eps_diffusion, c% eps_diffusion)
903 24 : if (failed('eps_diffusion')) exit
904 24 : call do1(s% g_field_element_diffusion, c% g_field_element_diffusion)
905 24 : if (failed('g_field_element_diffusion')) exit
906 :
907 24 : call do1(s% eps_phase_separation, c% eps_phase_separation)
908 24 : if (failed('eps_phase_separation')) exit
909 :
910 24 : call do1(s% non_nuc_neu, c% non_nuc_neu)
911 24 : if (failed('non_nuc_neu')) exit
912 24 : call do1(s% d_nonnucneu_dlnd, c% d_nonnucneu_dlnd)
913 24 : if (failed('d_nonnucneu_dlnd')) exit
914 24 : call do1(s% d_nonnucneu_dlnT, c% d_nonnucneu_dlnT)
915 24 : if (failed('d_nonnucneu_dlnT')) exit
916 :
917 24 : call do1(s% nonnucneu_plas, c% nonnucneu_plas)
918 24 : if (failed('nonnucneu_plas')) exit
919 24 : call do1(s% nonnucneu_brem, c% nonnucneu_brem)
920 24 : if (failed('nonnucneu_brem')) exit
921 24 : call do1(s% nonnucneu_phot, c% nonnucneu_phot)
922 24 : if (failed('nonnucneu_phot')) exit
923 24 : call do1(s% nonnucneu_pair, c% nonnucneu_pair)
924 24 : if (failed('nonnucneu_pair')) exit
925 24 : call do1(s% nonnucneu_reco, c% nonnucneu_reco)
926 24 : if (failed('nonnucneu_reco')) exit
927 :
928 24 : call do1(s% extra_opacity_factor, c% extra_opacity_factor)
929 24 : if (failed('extra_opacity_factor')) exit
930 :
931 24 : call do1_ad(s% extra_pressure, c% extra_pressure)
932 24 : if (failed('extra_pressure')) exit
933 24 : call do1(s% eps_heat, c% eps_heat)
934 24 : if (failed('eps_heat')) exit
935 24 : call do1(s% irradiation_heat, c% irradiation_heat)
936 24 : if (failed('irradiation_heat')) exit
937 :
938 24 : call do1_ad(s% extra_heat, c% extra_heat)
939 24 : if (failed('extra_heat')) exit
940 24 : call do1_ad(s% extra_grav, c% extra_grav)
941 24 : if (failed('extra_grav')) exit
942 :
943 24 : call do1(s% extra_jdot, c% extra_jdot)
944 24 : if (failed('extra_jdot')) exit
945 24 : call do1(s% extra_omegadot, c% extra_omegadot)
946 24 : if (failed('extra_omegadot')) exit
947 :
948 24 : call do1(s% d_extra_jdot_domega_m1, c% d_extra_jdot_domega_m1)
949 24 : if (failed('d_extra_jdot_domega_m1')) exit
950 24 : call do1(s% d_extra_omegadot_domega_m1, c% d_extra_omegadot_domega_m1)
951 24 : if (failed('d_extra_omegadot_domega_m1')) exit
952 24 : call do1(s% d_extra_jdot_domega_00, c% d_extra_jdot_domega_00)
953 24 : if (failed('d_extra_jdot_domega_00')) exit
954 24 : call do1(s% d_extra_omegadot_domega_00, c% d_extra_omegadot_domega_00)
955 24 : if (failed('d_extra_omegadot_domega_00')) exit
956 24 : call do1(s% d_extra_jdot_domega_p1, c% d_extra_jdot_domega_p1)
957 24 : if (failed('d_extra_jdot_domega_p1')) exit
958 24 : call do1(s% d_extra_omegadot_domega_p1, c% d_extra_omegadot_domega_p1)
959 24 : if (failed('d_extra_omegadot_domega_p1')) exit
960 :
961 24 : call do1(s% cgrav, c% cgrav)
962 24 : if (failed('cgrav')) exit
963 24 : if (action == do_allocate .or. &
964 : action == do_copy_pointers_and_resize) &
965 14570 : s% cgrav(1:nz) = standard_cgrav
966 :
967 24 : call do1(s% mesh_delta_coeff_factor, c% mesh_delta_coeff_factor)
968 24 : if (failed('mesh_delta_coeff_factor')) exit
969 24 : if (action == do_allocate .or. &
970 : action == do_copy_pointers_and_resize) &
971 14570 : s% mesh_delta_coeff_factor(1:nz) = 1d0
972 :
973 24 : call do1_logical(s% amr_split_merge_has_undergone_remesh, c% amr_split_merge_has_undergone_remesh)
974 24 : if (failed('amr_split_merge_has_undergone_remesh')) exit
975 :
976 24 : call do1(s% alpha_mlt, c% alpha_mlt)
977 24 : if (failed('alpha_mlt')) exit
978 24 : if (action == do_allocate .or. &
979 : action == do_copy_pointers_and_resize) &
980 14570 : s% alpha_mlt(1:nz) = s% mixing_length_alpha
981 :
982 24 : call do1(s% dvdt_drag, c% dvdt_drag)
983 24 : if (failed('dvdt_drag')) exit
984 :
985 24 : call do1(s% FdotV_drag_energy, c% FdotV_drag_energy)
986 24 : if (failed('FdotV_drag_energy')) exit
987 :
988 24 : call do1(s% vc, c% vc)
989 24 : if (failed('vc')) exit
990 :
991 24 : call do1_ad(s% eps_grav_ad, c% eps_grav_ad)
992 24 : if (failed('eps_grav_ad')) exit
993 24 : call do2(s% d_eps_grav_dx, c% d_eps_grav_dx, species, null_str)
994 24 : if (failed('d_eps_grav_dx')) exit
995 :
996 24 : call do1(s% eps_grav_composition_term, c% eps_grav_composition_term)
997 24 : if (failed('eps_grav_composition_term')) exit
998 :
999 24 : call do1(s% eps_mdot, c% eps_mdot)
1000 24 : if (failed('eps_mdot')) exit
1001 24 : call do1(s% dm_before_adjust_mass, c% dm_before_adjust_mass)
1002 24 : if (failed('dm_before_adjust_mass')) exit
1003 24 : call do1(s% total_energy_profile_before_adjust_mass, c% total_energy_profile_before_adjust_mass)
1004 24 : if (failed('total_energy_profile_before_adjust_mass')) exit
1005 24 : call do1(s% total_energy_profile_after_adjust_mass, c% total_energy_profile_after_adjust_mass)
1006 24 : if (failed('total_energy_profile_after_adjust_mass')) exit
1007 :
1008 24 : call do1(s% dL_dm, c% dL_dm)
1009 24 : if (failed('dL_dm')) exit
1010 24 : call do1(s% energy_sources, c% energy_sources)
1011 24 : if (failed('energy_sources')) exit
1012 24 : call do1(s% energy_others, c% energy_others)
1013 24 : if (failed('energy_others')) exit
1014 24 : call do1(s% dwork_dm, c% dwork_dm)
1015 24 : if (failed('dwork_dm')) exit
1016 24 : call do1(s% dkedt, c% dkedt)
1017 24 : if (failed('dkedt')) exit
1018 24 : call do1(s% dpedt, c% dpedt)
1019 24 : if (failed('dpedt')) exit
1020 24 : call do1(s% dedt, c% dedt)
1021 24 : if (failed('dedt')) exit
1022 24 : call do1(s% detrbdt, c% detrbdt)
1023 24 : if (failed('detrbdt')) exit
1024 :
1025 24 : call do1_integer(s% mlt_mixing_type, c% mlt_mixing_type)
1026 24 : if (failed('mlt_mixing_type')) exit
1027 24 : call do1(s% mlt_mixing_length, c% mlt_mixing_length)
1028 24 : if (failed('mlt_mixing_length')) exit
1029 24 : call do1(s% mlt_D, c% mlt_D)
1030 24 : if (failed('mlt_D')) exit
1031 :
1032 24 : call do1_logical(s% fixed_gradr_for_rest_of_solver_iters, c% fixed_gradr_for_rest_of_solver_iters)
1033 24 : if (failed('fixed_gradr_for_rest_of_solver_iters')) exit
1034 :
1035 24 : call do1(s% mlt_Gamma, c% mlt_Gamma)
1036 24 : if (failed('mlt_Gamma')) exit
1037 24 : call do1(s% L_conv, c% L_conv)
1038 24 : if (failed('L_conv')) exit
1039 :
1040 24 : call do1_integer(s% tdc_num_iters, c% tdc_num_iters)
1041 24 : if (failed('tdc_num_iters')) exit
1042 :
1043 24 : call do1(s% gradT_sub_grada, c% gradT_sub_grada)
1044 24 : if (failed('gradT_sub_grada')) exit
1045 24 : call do1(s% grada_face, c% grada_face)
1046 24 : if (failed('grada_face')) exit
1047 24 : call do1(s% mlt_gradT, c% mlt_gradT)
1048 24 : if (failed('mlt_gradT')) exit
1049 :
1050 24 : call do1(s% mlt_cdc, c% mlt_cdc)
1051 24 : if (failed('mlt_cdc')) exit
1052 24 : call do1(s% cdc, c% cdc)
1053 24 : if (failed('cdc')) exit
1054 24 : call do1(s% dvc_dt_TDC, c% dvc_dt_TDC)
1055 24 : if (failed('dvc_dt_TDC')) exit
1056 :
1057 24 : call do1(s% D_mix, c% D_mix)
1058 24 : if (failed('D_mix')) exit
1059 :
1060 24 : call do1_integer(s% mixing_type, c% mixing_type)
1061 24 : if (failed('mixing_type')) exit
1062 24 : call do1(s% cz_bdy_dq, c% cz_bdy_dq)
1063 24 : if (failed('cz_bdy_dq')) exit
1064 :
1065 24 : call do1_ad(s% gradT_ad, c% gradT_ad)
1066 24 : if (failed('gradT_ad')) exit
1067 24 : call do1_ad(s% gradr_ad, c% gradr_ad)
1068 24 : if (failed('gradr_ad')) exit
1069 24 : call do1_ad(s% Y_face_ad, c% Y_face_ad)
1070 24 : if (failed('Y_face_ad')) exit
1071 24 : call do1_ad(s% grada_face_ad, c% grada_face_ad)
1072 24 : if (failed('grada_face_ad')) exit
1073 24 : call do1_ad(s% mlt_vc_ad, c% mlt_vc_ad)
1074 24 : if (failed('mlt_vc_ad')) exit
1075 24 : call do1_ad(s% gradL_ad, c% gradL_ad)
1076 24 : if (failed('gradL_ad')) exit
1077 24 : call do1_ad(s% scale_height_ad, c% scale_height_ad)
1078 24 : if (failed('scale_height_ad')) exit
1079 24 : call do1_ad(s% Lambda_ad, c% Lambda_ad)
1080 24 : if (failed('Lambda_ad')) exit
1081 24 : call do1_ad(s% mlt_D_ad, c% mlt_D_ad)
1082 24 : if (failed('mlt_D_ad')) exit
1083 24 : call do1_ad(s% mlt_Gamma_ad, c% mlt_Gamma_ad)
1084 24 : if (failed('mlt_Gamma_ad')) exit
1085 :
1086 24 : call do1_ad(s% PII_ad, c% PII_ad)
1087 24 : if (failed('PII_ad')) exit
1088 24 : call do1_ad(s% Chi_ad, c% Chi_ad)
1089 24 : if (failed('Chi_ad')) exit
1090 24 : call do1_ad(s% Eq_ad, c% Eq_ad)
1091 24 : if (failed('Eq_ad')) exit
1092 24 : call do1_ad(s% COUPL_ad, c% COUPL_ad)
1093 24 : if (failed('COUPL_ad')) exit
1094 24 : call do1_ad(s% Lr_ad, c% Lr_ad)
1095 24 : if (failed('Lr_ad')) exit
1096 24 : call do1_ad(s% Lc_ad, c% Lc_ad)
1097 24 : if (failed('Lc_ad')) exit
1098 24 : call do1_ad(s% Lt_ad, c% Lt_ad)
1099 24 : if (failed('Lt_ad')) exit
1100 :
1101 24 : call do1(s% gradT, c% gradT)
1102 24 : if (failed('gradT')) exit
1103 24 : call do1(s% gradr, c% gradr)
1104 24 : if (failed('gradr')) exit
1105 :
1106 24 : call do1(s% grad_density, c% grad_density)
1107 24 : if (failed('grad_density')) exit
1108 24 : call do1(s% grad_temperature, c% grad_temperature)
1109 24 : if (failed('grad_temperature')) exit
1110 24 : call do1(s% gradL, c% gradL)
1111 24 : if (failed('gradL')) exit
1112 24 : call do1(s% gradL_composition_term, c% gradL_composition_term)
1113 24 : if (failed('gradL_composition_term')) exit
1114 :
1115 : call do1_integer( &
1116 24 : s% dominant_iso_for_thermohaline, c% dominant_iso_for_thermohaline)
1117 24 : if (failed('dominant_iso_for_thermohaline')) exit
1118 :
1119 24 : call do1(s% sig, c% sig)
1120 24 : if (failed('sig')) exit
1121 24 : call do1(s% sig_raw, c% sig_raw)
1122 24 : if (failed('sig_raw')) exit
1123 :
1124 24 : call do1(s% brunt_N2, c% brunt_N2)
1125 24 : if (failed('brunt_N2')) exit
1126 24 : call do1(s% brunt_N2_composition_term, c% brunt_N2_composition_term)
1127 24 : if (failed('brunt_N2_composition_term')) exit
1128 24 : call do1(s% brunt_B, c% brunt_B)
1129 24 : if (failed('brunt_B')) exit
1130 24 : call do1(s% unsmoothed_brunt_B, c% unsmoothed_brunt_B)
1131 24 : if (failed('unsmoothed_brunt_B')) exit
1132 24 : call do1(s% smoothed_brunt_B, c% smoothed_brunt_B)
1133 24 : if (failed('smoothed_brunt_B')) exit
1134 :
1135 24 : call do1(s% RTI_du_diffusion_kick, c% RTI_du_diffusion_kick)
1136 24 : if (failed('RTI_du_diffusion_kick')) exit
1137 :
1138 24 : call do1_ad(s% u_face_ad, c% u_face_ad)
1139 24 : if (failed('u_face_ad')) exit
1140 24 : call do1(s% u_face_start, c% u_face_start)
1141 24 : if (failed('u_face_start')) exit
1142 24 : call do1(s% u_face_val, c% u_face_val)
1143 24 : if (failed('u_face_val')) exit
1144 24 : call do1(s% d_uface_domega, c% d_uface_domega)
1145 24 : if (failed('d_uface_domega')) exit
1146 :
1147 24 : call do1_ad(s% P_face_ad, c% P_face_ad)
1148 24 : if (failed('P_face_ad')) exit
1149 24 : call do1(s% P_face_start, c% P_face_start)
1150 24 : if (failed('P_face_start')) exit
1151 24 : call do1(s% abs_du_div_cs, c% abs_du_div_cs)
1152 24 : if (failed('abs_du_div_cs')) exit
1153 24 : call do1(s% abs_du_plus_cs, c% abs_du_plus_cs)
1154 24 : if (failed('abs_du_plus_cs')) exit
1155 :
1156 24 : call do1(s% dPdr_dRhodr_info, c% dPdr_dRhodr_info)
1157 24 : if (failed('dPdr_dRhodr_info')) exit
1158 24 : call do1(s% dPdr_info, c% dPdr_info)
1159 24 : if (failed('dPdr_info')) exit
1160 24 : call do1(s% dRhodr_info, c% dRhodr_info)
1161 24 : if (failed('dRhodr_info')) exit
1162 :
1163 24 : call do1(s% source_plus_alpha_RTI, c% source_plus_alpha_RTI)
1164 24 : if (failed('source_plus_alpha_RTI')) exit
1165 24 : call do1(s% source_minus_alpha_RTI, c% source_minus_alpha_RTI)
1166 24 : if (failed('source_minus_alpha_RTI')) exit
1167 24 : call do1(s% eta_RTI, c% eta_RTI)
1168 24 : if (failed('eta_RTI')) exit
1169 24 : call do1(s% etamid_RTI, c% etamid_RTI)
1170 24 : if (failed('etamid_RTI')) exit
1171 24 : call do1(s% boost_for_eta_RTI, c% boost_for_eta_RTI)
1172 24 : if (failed('boost_for_eta_RTI')) exit
1173 :
1174 24 : call do1(s% sig_RTI, c% sig_RTI)
1175 24 : if (failed('sig_RTI')) exit
1176 24 : call do1(s% sigmid_RTI, c% sigmid_RTI)
1177 24 : if (failed('sigmid_RTI')) exit
1178 :
1179 24 : call do1(s% L_nuc_burn, c% L_nuc_burn)
1180 24 : if (failed('L_nuc_burn')) exit
1181 :
1182 24 : call do2(s% xa_start, c% xa_start, species, 'xa_start')
1183 24 : if (failed('xa_start')) exit
1184 24 : call do2(s% xa_sub_xa_start, c% xa_sub_xa_start, species, 'xa_sub_xa_start')
1185 24 : if (failed('xa_sub_xa_start')) exit
1186 :
1187 24 : call do1(s% lnd_start, c% lnd_start)
1188 24 : if (failed('lnd_start')) exit
1189 24 : call do1(s% lnPgas_start, c% lnPgas_start)
1190 24 : if (failed('lnPgas_start')) exit
1191 24 : call do1(s% lnPeos_start, c% lnPeos_start)
1192 24 : if (failed('lnPeos_start')) exit
1193 24 : call do1(s% Peos_start, c% Peos_start)
1194 24 : if (failed('Peos_start')) exit
1195 24 : call do1(s% lnT_start, c% lnT_start)
1196 24 : if (failed('lnT_start')) exit
1197 24 : call do1(s% energy_start, c% energy_start)
1198 24 : if (failed('energy_start')) exit
1199 24 : call do1(s% egas_start, c% egas_start)
1200 24 : if (failed('egas_start')) exit
1201 24 : call do1(s% erad_start, c% erad_start)
1202 24 : if (failed('erad_start')) exit
1203 24 : call do1(s% Pgas_start, c% Pgas_start)
1204 24 : if (failed('Pgas_start')) exit
1205 24 : call do1(s% Prad_start, c% Prad_start)
1206 24 : if (failed('Prad_start')) exit
1207 24 : call do1(s% lnR_start, c% lnR_start)
1208 24 : if (failed('lnR_start')) exit
1209 24 : call do1(s% v_start, c% v_start)
1210 24 : if (failed('v_start')) exit
1211 24 : call do1(s% u_start, c% u_start)
1212 24 : if (failed('u_start')) exit
1213 24 : call do1(s% L_start, c% L_start)
1214 24 : if (failed('L_start')) exit
1215 24 : call do1(s% r_start, c% r_start)
1216 24 : if (failed('r_start')) exit
1217 24 : call do1(s% rmid_start, c% rmid_start)
1218 24 : if (failed('rmid_start')) exit
1219 24 : call do1(s% omega_start, c% omega_start)
1220 24 : if (failed('omega_start')) exit
1221 24 : call do1(s% ye_start, c% ye_start)
1222 24 : if (failed('ye_start')) exit
1223 24 : call do1(s% opacity_start, c% opacity_start)
1224 24 : if (failed('opacity_start')) exit
1225 24 : call do1(s% csound_start, c% csound_start)
1226 24 : if (failed('csound_start')) exit
1227 24 : call do1(s% alpha_RTI_start, c% alpha_RTI_start)
1228 24 : if (failed('alpha_RTI_start')) exit
1229 :
1230 24 : call do1(s% j_rot_start, c% j_rot_start)
1231 24 : if (failed('j_rot_start')) exit
1232 24 : call do1(s% i_rot_start, c% i_rot_start)
1233 24 : if (failed('i_rot_start')) exit
1234 24 : call do1(s% eps_nuc_start, c% eps_nuc_start)
1235 24 : if (failed('eps_nuc_start')) exit
1236 24 : call do1(s% non_nuc_neu_start, c% non_nuc_neu_start)
1237 24 : if (failed('non_nuc_neu_start')) exit
1238 24 : call do2(s% dxdt_nuc_start, c% dxdt_nuc_start, species, null_str)
1239 24 : if (failed('dxdt_nuc_start')) exit
1240 24 : call do1(s% grada_start, c% grada_start)
1241 24 : if (failed('grada_start')) exit
1242 24 : call do1(s% chiT_start, c% chiT_start)
1243 24 : if (failed('chiT_start')) exit
1244 24 : call do1(s% chiRho_start, c% chiRho_start)
1245 24 : if (failed('chiRho_start')) exit
1246 24 : call do1(s% cp_start, c% cp_start)
1247 24 : if (failed('cp_start')) exit
1248 24 : call do1(s% Cv_start, c% Cv_start)
1249 24 : if (failed('Cv_start')) exit
1250 24 : call do1(s% dE_dRho_start, c% dE_dRho_start)
1251 24 : if (failed('dE_dRho_start')) exit
1252 24 : call do1(s% gam_start, c% gam_start)
1253 24 : if (failed('gam_start')) exit
1254 24 : call do1(s% rho_start, c% rho_start)
1255 24 : if (failed('rho_start')) exit
1256 24 : call do1(s% lnS_start, c% lnS_start)
1257 24 : if (failed('lnS_start')) exit
1258 24 : call do1(s% T_start, c% T_start)
1259 24 : if (failed('T_start')) exit
1260 24 : call do1(s% zbar_start, c% zbar_start)
1261 24 : if (failed('zbar_start')) exit
1262 24 : call do1(s% mu_start, c% mu_start)
1263 24 : if (failed('mu_start')) exit
1264 :
1265 24 : call do1(s% phase_start, c% phase_start)
1266 24 : if (failed('phase_start')) exit
1267 24 : call do1(s% latent_ddlnT_start, c% latent_ddlnT_start)
1268 24 : if (failed('latent_ddlnT_start')) exit
1269 24 : call do1(s% latent_ddlnRho_start, c% latent_ddlnRho_start)
1270 24 : if (failed('latent_ddlnRho_start')) exit
1271 :
1272 24 : call do1(s% max_burn_correction, c% max_burn_correction)
1273 24 : if (failed('max_burn_correction')) exit
1274 24 : call do1(s% avg_burn_correction, c% avg_burn_correction)
1275 24 : if (failed('avg_burn_correction')) exit
1276 :
1277 24 : call do1(s% burn_avg_epsnuc, c% burn_avg_epsnuc)
1278 24 : if (failed('burn_avg_epsnuc')) exit
1279 24 : call do1_integer(s% burn_num_iters, c% burn_num_iters)
1280 24 : if (failed('burn_num_iters')) exit
1281 :
1282 24 : call do1_neq(s% residual_weight1, c% residual_weight1)
1283 24 : if (failed('residual_weight1')) exit
1284 24 : if (action == do_remove_from_center .or. action == do_reallocate .or. &
1285 : (action /= do_check_size .and. action /= do_deallocate)) &
1286 11 : s% residual_weight(1:nvar,1:nz) => s% residual_weight1(1:nvar*nz)
1287 :
1288 24 : call do1_neq(s% correction_weight1, c% correction_weight1)
1289 24 : if (failed('correction_weight1')) exit
1290 24 : if (action == do_remove_from_center .or. action == do_reallocate .or. &
1291 : (action /= do_check_size .and. action /= do_deallocate)) &
1292 11 : s% correction_weight(1:nvar,1:nz) => s% correction_weight1(1:nvar*nz)
1293 :
1294 24 : call do1_neq(s% solver_dx1, c% solver_dx1)
1295 24 : if (failed('solver_dx1')) exit
1296 24 : if (action == do_remove_from_center .or. action == do_reallocate .or. &
1297 : (action /= do_check_size .and. action /= do_deallocate)) &
1298 11 : s% solver_dx(1:nvar,1:nz) => s% solver_dx1(1:nvar*nz)
1299 :
1300 24 : call do1_neq(s% x_scale1, c% x_scale1)
1301 24 : if (failed('x_scale1')) exit
1302 24 : if (action == do_remove_from_center .or. action == do_reallocate .or. &
1303 : (action /= do_check_size .and. action /= do_deallocate)) &
1304 11 : s% x_scale(1:nvar,1:nz) => s% x_scale1(1:nvar*nz)
1305 :
1306 24 : call do1(s% eps_pre_mix, c% eps_pre_mix)
1307 24 : if (failed('eps_pre_mix')) exit
1308 :
1309 24 : call do1(s% max_abs_xa_corr, c% max_abs_xa_corr)
1310 24 : if (failed('max_abs_xa_corr')) exit
1311 :
1312 24 : call do1(s% Hp_face, c% Hp_face); if (failed('Hp_face')) exit
1313 :
1314 24 : call do1(s% Y_face, c% Y_face); if (failed('Y_face')) exit
1315 24 : call do1(s% Y_face_start, c% Y_face_start); if (failed('Y_face_start')) exit
1316 :
1317 24 : call do1(s% PII, c% PII); if (failed('PII')) exit
1318 :
1319 24 : call do1(s% Chi, c% Chi); if (failed('Chi')) exit
1320 24 : call do1(s% Chi_start, c% Chi_start); if (failed('Chi_start')) exit
1321 :
1322 24 : call do1(s% Lr, c% Lr); if (failed('Lr')) exit
1323 24 : call do1(s% Lc, c% Lc); if (failed('Lc')) exit
1324 24 : call do1(s% Lc_start, c% Lc_start); if (failed('Lc_start')) exit
1325 24 : call do1(s% Lt, c% Lt); if (failed('Lt')) exit
1326 24 : call do1(s% Lt_start, c% Lt_start); if (failed('Lt_start')) exit
1327 :
1328 24 : call do1(s% Fr, c% Fr); if (failed('Fr')) exit
1329 24 : call do1(s% Fr_start, c% Fr_start); if (failed('Fr_start')) exit
1330 24 : call do1(s% Pvsc, c% Pvsc); if (failed('Pvsc')) exit
1331 24 : call do1(s% Pvsc_start, c% Pvsc_start); if (failed('Pvsc_start')) exit
1332 24 : call do1(s% Ptrb, c% Ptrb); if (failed('Ptrb')) exit
1333 24 : call do1(s% Ptrb_start, c% Ptrb_start); if (failed('Ptrb_start')) exit
1334 24 : call do1(s% Eq, c% Eq); if (failed('Eq')) exit
1335 24 : call do1(s% SOURCE, c% SOURCE); if (failed('SOURCE')) exit
1336 24 : call do1(s% DAMP, c% DAMP); if (failed('DAMP')) exit
1337 24 : call do1(s% DAMPR, c% DAMPR); if (failed('DAMPR')) exit
1338 24 : call do1(s% COUPL, c% COUPL); if (failed('COUPL')) exit
1339 24 : call do1(s% COUPL_start, c% COUPL_start); if (failed('COUPL_start')) exit
1340 24 : call do1(s% RSP_w, c% RSP_w); if (failed('w')) exit
1341 24 : call do1(s% RSP_w_start, c% RSP_w_start); if (failed('w_start')) exit
1342 24 : call do1(s% Vol, c% Vol); if (failed('Vol')) exit
1343 24 : call do1(s% Vol_start, c% Vol_start); if (failed('Vol_start')) exit
1344 24 : call do1(s% Uq, c% Uq); if (failed('Uq')) exit
1345 24 : call do1(s% f_Edd, c% f_Edd); if (failed('f_Edd')) exit
1346 :
1347 24 : call do1(s% xtra1_array, c% xtra1_array)
1348 24 : if (failed('xtra1_array')) exit
1349 24 : call do1(s% xtra2_array, c% xtra2_array)
1350 24 : if (failed('xtra2_array')) exit
1351 24 : call do1(s% xtra3_array, c% xtra3_array)
1352 24 : if (failed('xtra3_array')) exit
1353 24 : call do1(s% xtra4_array, c% xtra4_array)
1354 24 : if (failed('xtra4_array')) exit
1355 24 : call do1(s% xtra5_array, c% xtra5_array)
1356 24 : if (failed('xtra5_array')) exit
1357 24 : call do1(s% xtra6_array, c% xtra6_array)
1358 24 : if (failed('xtra6_array')) exit
1359 :
1360 24 : call do1_integer(s% ixtra1_array, c% ixtra1_array)
1361 24 : if (failed('ixtra1_array')) exit
1362 24 : call do1_integer(s% ixtra2_array, c% ixtra2_array)
1363 24 : if (failed('ixtra2_array')) exit
1364 24 : call do1_integer(s% ixtra3_array, c% ixtra3_array)
1365 24 : if (failed('ixtra3_array')) exit
1366 24 : call do1_integer(s% ixtra4_array, c% ixtra4_array)
1367 24 : if (failed('ixtra4_array')) exit
1368 24 : call do1_integer(s% ixtra5_array, c% ixtra5_array)
1369 24 : if (failed('ixtra5_array')) exit
1370 24 : call do1_integer(s% ixtra6_array, c% ixtra6_array)
1371 24 : if (failed('ixtra6_array')) exit
1372 :
1373 24 : if (action_in /= do_check_size) then
1374 13 : if (action_in /= do_copy_pointers_and_resize .and. &
1375 : action_in /= do_reallocate) then
1376 3 : call do2D_dim1(s, s% profile_extra, nz, max_num_profile_extras, action, ierr)
1377 : else
1378 10 : deallocate(s% profile_extra)
1379 10 : allocate(s% profile_extra(nz, max_num_profile_extras), stat=ierr)
1380 : end if
1381 13 : if (failed('pstar extras')) exit
1382 : end if
1383 :
1384 24 : call do2(s% prev_mesh_xh, c% prev_mesh_xh, nvar_hydro, 'prev_mesh_xh')
1385 24 : if (failed('prev_mesh_xh')) exit
1386 24 : call do2(s% prev_mesh_xa, c% prev_mesh_xa, species, 'prev_mesh_xa')
1387 24 : if (failed('prev_mesh_xa')) exit
1388 24 : call do1(s% prev_mesh_j_rot, c% prev_mesh_j_rot)
1389 24 : if (failed('prev_mesh_j_rot')) exit
1390 24 : call do1(s% prev_mesh_omega, c% prev_mesh_omega)
1391 24 : if (failed('prev_mesh_omega')) exit
1392 24 : call do1(s% prev_mesh_mlt_vc, c% prev_mesh_mlt_vc)
1393 24 : if (failed('prev_mesh_mlt_vc')) exit
1394 24 : call do1(s% prev_mesh_dq, c% prev_mesh_dq)
1395 24 : if (failed('prev_mesh_dq')) exit
1396 : ! These are needed for time-smoothing of ST mixing
1397 24 : call do1(s% prev_mesh_D_ST_start, c% prev_mesh_D_ST_start)
1398 24 : if (failed('prev_mesh_D_ST_start')) exit
1399 24 : call do1(s% prev_mesh_nu_ST_start, c% prev_mesh_nu_ST_start)
1400 24 : if (failed('prev_mesh_nu_ST_start')) exit
1401 :
1402 24 : if (s% fill_arrays_with_NaNs) s% need_to_setvars = .true.
1403 0 : return
1404 : end do
1405 24 : ierr = -1
1406 :
1407 :
1408 : contains
1409 :
1410 :
1411 648 : subroutine do1_ad(ptr, other)
1412 : type(auto_diff_real_star_order1), dimension(:), pointer :: ptr, other
1413 648 : if (action == do_fill_arrays_with_NaNs) then
1414 0 : call fill_ad_with_NaNs(ptr,1,-1)
1415 648 : else if (action == do_copy_pointers_and_resize) then
1416 243 : ptr => other
1417 243 : if (nz <= size(ptr,dim=1)) then
1418 243 : if (s% fill_arrays_with_NaNs) call fill_ad_with_NaNs(ptr,1,-1)
1419 243 : return
1420 : end if
1421 0 : deallocate(ptr)
1422 0 : allocate(ptr(sz_new), stat=ierr)
1423 0 : if (s% fill_arrays_with_NaNs) call fill_ad_with_NaNs(ptr,1,-1)
1424 0 : if (s% zero_when_allocate) call fill_ad_with_zeros(ptr,1,-1)
1425 : else
1426 405 : if (action == do_reallocate) then
1427 0 : if (nz <= size(ptr,dim=1)) return
1428 : end if
1429 405 : call do1D_ad(s, ptr, sz_new, action, ierr)
1430 405 : if (action == do_allocate) then
1431 54 : if (s% fill_arrays_with_NaNs) call fill_ad_with_NaNs(ptr,1,-1)
1432 54 : if (s% zero_when_allocate) call fill_ad_with_zeros(ptr,1,-1)
1433 : end if
1434 : end if
1435 24 : end subroutine do1_ad
1436 :
1437 :
1438 7512 : subroutine do1(ptr, other)
1439 : real(dp), dimension(:), pointer :: ptr, other
1440 7512 : if (action == do_fill_arrays_with_NaNs) then
1441 0 : call fill_with_NaNs(ptr)
1442 7512 : else if (action == do_copy_pointers_and_resize) then
1443 2817 : ptr => other
1444 2817 : if (.not. associated(ptr)) then
1445 0 : call mesa_error(__FILE__,__LINE__,'do1 ptr not associated')
1446 : end if
1447 2817 : if (nz <= size(ptr,dim=1)) then
1448 2817 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1449 2817 : return
1450 : end if
1451 0 : deallocate(ptr)
1452 0 : allocate(ptr(sz_new), stat=ierr)
1453 0 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1454 0 : if (s% zero_when_allocate) ptr(:) = 0
1455 : else
1456 4695 : if (action == do_reallocate) then
1457 0 : if (nz <= size(ptr,dim=1)) return
1458 : end if
1459 4695 : call do1D(s, ptr, sz_new, action, ierr)
1460 4695 : if (action == do_allocate) then
1461 626 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1462 626 : if (s% zero_when_allocate) ptr(:) = 0
1463 : end if
1464 : end if
1465 : end subroutine do1
1466 :
1467 :
1468 96 : subroutine do1_neq(ptr, other)
1469 : real(dp), dimension(:), pointer :: ptr, other
1470 96 : if (action == do_fill_arrays_with_NaNs) then
1471 0 : call fill_with_NaNs(ptr)
1472 96 : else if (action == do_copy_pointers_and_resize) then
1473 36 : ptr => other
1474 36 : if (nvar*nz <= size(ptr,dim=1)) then
1475 36 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1476 36 : if (s% zero_when_allocate) ptr(:) = 0
1477 36 : return
1478 : end if
1479 0 : deallocate(ptr)
1480 0 : allocate(ptr(nvar*sz_new), stat=ierr)
1481 0 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1482 0 : if (s% zero_when_allocate) ptr(:) = 0
1483 : else
1484 60 : if (action == do_reallocate) then
1485 0 : if (nvar*nz <= size(ptr,dim=1)) return
1486 : end if
1487 60 : call do1D(s, ptr, nvar*sz_new, action, ierr)
1488 60 : if (action == do_allocate) then
1489 8 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1490 8 : if (s% zero_when_allocate) ptr(:) = 0
1491 : end if
1492 : end if
1493 : end subroutine do1_neq
1494 :
1495 :
1496 264 : subroutine do1_integer(ptr, other)
1497 : integer, dimension(:), pointer :: ptr, other
1498 264 : if (action == do_copy_pointers_and_resize) then
1499 99 : ptr => other
1500 99 : if (nz <= size(ptr,dim=1)) return
1501 0 : deallocate(ptr)
1502 0 : allocate(ptr(sz_new), stat=ierr)
1503 : else
1504 165 : if (action == do_reallocate) then
1505 0 : if (nz <= size(ptr,dim=1)) return
1506 : end if
1507 165 : call do1D_integer(s, ptr, sz_new, action, ierr)
1508 : end if
1509 : end subroutine do1_integer
1510 :
1511 :
1512 : subroutine do2_integer(ptr, other, sz1)
1513 : integer, dimension(:,:), pointer :: ptr, other
1514 : integer, intent(in) :: sz1
1515 : if (action == do_copy_pointers_and_resize) then
1516 : ptr => other
1517 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) return
1518 : deallocate(ptr)
1519 : allocate(ptr(sz1, sz_new), stat=ierr)
1520 : else
1521 : if (action == do_reallocate) then
1522 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) return
1523 : end if
1524 : call do2D_integer(s, ptr, sz1, sz_new, action, ierr)
1525 : end if
1526 : end subroutine do2_integer
1527 :
1528 :
1529 48 : subroutine do1_logical(ptr, other)
1530 : logical, dimension(:), pointer :: ptr, other
1531 48 : if (action == do_copy_pointers_and_resize) then
1532 18 : ptr => other
1533 18 : if (nz <= size(ptr,dim=1)) return
1534 0 : deallocate(ptr)
1535 0 : allocate(ptr(sz_new), stat=ierr)
1536 : else
1537 30 : if (action == do_reallocate) then
1538 0 : if (nz <= size(ptr,dim=1)) return
1539 : end if
1540 30 : call do1D_logical(s, ptr, sz_new, action, ierr)
1541 : end if
1542 : end subroutine do1_logical
1543 :
1544 :
1545 748 : subroutine do2(ptr, other, sz1, str)
1546 : real(dp), dimension(:,:), pointer :: ptr, other
1547 : integer, intent(in) :: sz1
1548 : character (len=*), intent(in) :: str
1549 : include 'formats'
1550 748 : if (action == do_fill_arrays_with_NaNs) then
1551 0 : call fill_with_NaNs_2d(ptr)
1552 748 : else if (action == do_copy_pointers_and_resize) then
1553 297 : ptr => other
1554 297 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) then
1555 297 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_2d(ptr)
1556 297 : if (s% zero_when_allocate) ptr(:,:) = 0
1557 297 : return
1558 : end if
1559 0 : deallocate(ptr)
1560 0 : allocate(ptr(sz1, sz_new), stat=ierr)
1561 0 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_2d(ptr)
1562 0 : if (s% zero_when_allocate) ptr(:,:) = 0
1563 : else
1564 451 : if (action == do_reallocate) then
1565 0 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) return
1566 : end if
1567 451 : call do2D(s, ptr, sz1, sz_new, action, ierr)
1568 451 : if (action == do_allocate) then
1569 66 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_2d(ptr)
1570 66 : if (s% zero_when_allocate) ptr(:,:) = 0
1571 : end if
1572 : end if
1573 : end subroutine do2
1574 :
1575 :
1576 48 : subroutine do3(ptr, other, sz1, sz2)
1577 : real(dp), dimension(:,:,:), pointer :: ptr, other
1578 : integer, intent(in) :: sz1, sz2
1579 48 : if (action == do_fill_arrays_with_NaNs) then
1580 0 : call fill_with_NaNs_3d(ptr)
1581 48 : elseif (action == do_copy_pointers_and_resize) then
1582 18 : ptr => other
1583 : if (sz1 == size(ptr, dim=1) .and. sz2 == size(ptr, dim=2) &
1584 18 : .and. nz <= size(ptr, dim=3)) then
1585 18 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_3d(ptr)
1586 18 : if (s% zero_when_allocate) ptr(:,:,:) = 0
1587 18 : return
1588 : end if
1589 0 : deallocate(ptr)
1590 0 : allocate(ptr(sz1, sz2, sz_new), stat=ierr)
1591 0 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_3d(ptr)
1592 0 : if (s% zero_when_allocate) ptr(:,:,:) = 0
1593 : else
1594 30 : if (action == do_reallocate) then
1595 : if (sz1 == size(ptr, dim=1) .and. &
1596 0 : sz2 == size(ptr, dim=2) .and. &
1597 : nz <= size(ptr, dim=3)) return
1598 : end if
1599 30 : call do3D(s, ptr, sz1, sz2, sz_new, action, ierr)
1600 30 : if (action == do_allocate) then
1601 4 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_3d(ptr)
1602 4 : if (s% zero_when_allocate) ptr(:,:,:) = 0
1603 : end if
1604 : end if
1605 : end subroutine do3
1606 :
1607 :
1608 : subroutine do2_quad(ptr, other, sz1)
1609 : real(qp), dimension(:,:), pointer :: ptr, other
1610 : integer, intent(in) :: sz1
1611 : if (action == do_copy_pointers_and_resize) then
1612 : ptr => other
1613 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) return
1614 : deallocate(ptr)
1615 : allocate(ptr(sz1, sz_new), stat=ierr)
1616 : else
1617 : if (action == do_reallocate) then
1618 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) return
1619 : end if
1620 : call do2D_quad(s, ptr, sz1, sz_new, action, ierr)
1621 : end if
1622 : end subroutine do2_quad
1623 :
1624 :
1625 9377 : logical function failed(str)
1626 : character (len=*), intent(in) :: str
1627 : include 'formats'
1628 9377 : failed = .false.
1629 9377 : if (ierr == 0) return
1630 0 : write(*,*) 'star_info_arrays failed for ' // trim(str)
1631 0 : write(*,2) 'action', action
1632 0 : write(*,2) 'species', species
1633 0 : write(*,2) 'nz', nz
1634 0 : failed = .true.
1635 0 : end function failed
1636 :
1637 :
1638 : end subroutine star_info_arrays
1639 :
1640 :
1641 0 : subroutine fill_ad_with_NaNs(ptr, klo, khi_in)
1642 : type(auto_diff_real_star_order1), dimension(:), pointer :: ptr
1643 : integer, intent(in) :: klo, khi_in
1644 : integer :: k, khi
1645 0 : if (khi_in == -1) then
1646 0 : khi = size(ptr,dim=1)
1647 : else
1648 : khi = khi_in
1649 : end if
1650 0 : do k=klo,khi
1651 0 : call set_nan(ptr(k)% val)
1652 0 : call fill_with_NaNs(ptr(k)% d1Array)
1653 : end do
1654 0 : end subroutine fill_ad_with_NaNs
1655 :
1656 :
1657 1 : subroutine fill_ad_with_zeros(ptr, klo, khi_in)
1658 : type(auto_diff_real_star_order1), dimension(:), pointer :: ptr
1659 : integer, intent(in) :: klo, khi_in
1660 : integer :: k, khi
1661 1 : if (khi_in == -1) then
1662 1 : khi = size(ptr,dim=1)
1663 : else
1664 : khi = khi_in
1665 : end if
1666 2665 : do k=klo,khi
1667 2664 : ptr(k)% val = 0d0
1668 90577 : ptr(k)% d1Array(:) = 0d0
1669 : end do
1670 1 : end subroutine fill_ad_with_zeros
1671 :
1672 :
1673 405 : subroutine do1D_ad(s, ptr, sz, action, ierr)
1674 : type (star_info), pointer :: s
1675 : type(auto_diff_real_star_order1), dimension(:), pointer :: ptr
1676 : integer, intent(in) :: sz, action
1677 : integer, intent(out) :: ierr
1678 405 : type(auto_diff_real_star_order1), dimension(:), pointer :: ptr2
1679 : integer :: old_sz, j
1680 : include 'formats'
1681 405 : ierr = 0
1682 459 : select case(action)
1683 : case (do_deallocate)
1684 54 : if (associated(ptr)) then
1685 54 : deallocate(ptr)
1686 : nullify(ptr)
1687 : end if
1688 : case (do_allocate)
1689 54 : allocate(ptr(sz), stat=ierr)
1690 54 : if (s% fill_arrays_with_NaNs) then
1691 0 : call fill_ad_with_NaNs(ptr,1,-1)
1692 54 : else if (s% zero_when_allocate) then
1693 0 : call fill_ad_with_zeros(ptr,1,-1)
1694 : end if
1695 : case (do_check_size)
1696 297 : if (size(ptr,dim=1) < sz) ierr = -1
1697 : case (do_remove_from_center)
1698 0 : allocate(ptr2(sz), stat=ierr)
1699 0 : old_sz = size(ptr,dim=1)
1700 0 : do j=1,min(old_sz,sz)
1701 0 : ptr2(j) = ptr(j)
1702 : end do
1703 0 : deallocate(ptr)
1704 0 : if (ierr /= 0) return
1705 0 : ptr => ptr2
1706 : case (do_reallocate)
1707 0 : if (associated(ptr)) then
1708 0 : if (size(ptr,dim=1) >= sz) return
1709 : else
1710 0 : ierr = -1
1711 0 : return
1712 : end if
1713 0 : allocate(ptr2(sz), stat=ierr)
1714 0 : old_sz = size(ptr,dim=1)
1715 0 : do j=1,old_sz
1716 0 : ptr2(j) = ptr(j)
1717 : end do
1718 0 : if (s% fill_arrays_with_NaNs) then
1719 0 : call fill_ad_with_NaNs(ptr2,old_sz+1,sz)
1720 0 : else if (s% zero_when_allocate) then
1721 0 : call fill_ad_with_zeros(ptr2,old_sz+1,sz)
1722 : end if
1723 0 : deallocate(ptr)
1724 0 : if (ierr /= 0) return
1725 0 : ptr => ptr2
1726 : case (do_fill_arrays_with_NaNs)
1727 0 : if (associated(ptr)) call fill_ad_with_NaNs(ptr,1,-1)
1728 : end select
1729 405 : end subroutine do1D_ad
1730 :
1731 :
1732 4815 : subroutine do1D(s, ptr, sz, action, ierr)
1733 : type (star_info), pointer :: s
1734 : real(dp), dimension(:), pointer :: ptr
1735 : integer, intent(in) :: sz, action
1736 : integer, intent(out) :: ierr
1737 4815 : real(dp), dimension(:), pointer :: ptr2
1738 : integer :: old_sz, j
1739 : include 'formats'
1740 4815 : ierr = 0
1741 5454 : select case(action)
1742 : case (do_deallocate)
1743 639 : if (associated(ptr)) then
1744 639 : deallocate(ptr)
1745 : nullify(ptr)
1746 : end if
1747 : case (do_allocate)
1748 634 : allocate(ptr(sz), stat=ierr)
1749 634 : if (s% fill_arrays_with_NaNs) then
1750 0 : call set_nan(ptr)
1751 634 : else if (s% zero_when_allocate) then
1752 0 : ptr(1:sz) = 0
1753 : end if
1754 : case (do_check_size)
1755 3542 : if (size(ptr,dim=1) < sz) ierr = -1
1756 : case (do_remove_from_center)
1757 0 : allocate(ptr2(sz), stat=ierr)
1758 0 : old_sz = size(ptr,dim=1)
1759 0 : do j=1,min(old_sz,sz)
1760 0 : ptr2(j) = ptr(j)
1761 : end do
1762 0 : deallocate(ptr)
1763 0 : if (ierr /= 0) return
1764 0 : ptr => ptr2
1765 : case (do_reallocate)
1766 0 : if (associated(ptr)) then
1767 0 : if (size(ptr,dim=1) >= sz) return
1768 : else
1769 0 : ierr = -1
1770 0 : return
1771 : end if
1772 0 : allocate(ptr2(sz), stat=ierr)
1773 0 : old_sz = size(ptr,dim=1)
1774 0 : do j=1,old_sz
1775 0 : ptr2(j) = ptr(j)
1776 : end do
1777 0 : if (s% fill_arrays_with_NaNs) then
1778 0 : do j=old_sz+1,sz
1779 0 : call set_nan(ptr2(j))
1780 : end do
1781 0 : else if (s% zero_when_allocate) then
1782 0 : do j=old_sz+1,sz
1783 0 : ptr2(j) = 0
1784 : end do
1785 : end if
1786 0 : deallocate(ptr)
1787 0 : if (ierr /= 0) return
1788 0 : ptr => ptr2
1789 : case (do_fill_arrays_with_NaNs)
1790 0 : if (associated(ptr)) call set_nan(ptr)
1791 : end select
1792 4815 : end subroutine do1D
1793 :
1794 :
1795 475 : subroutine do2D(s, ptr, sz1, sz2, action, ierr)
1796 :
1797 : type (star_info), pointer :: s
1798 : real(dp), dimension(:,:), pointer:: ptr
1799 : integer, intent(in) :: sz1, sz2, action
1800 : integer, intent(out) :: ierr
1801 475 : real(dp), dimension(:,:), pointer :: ptr2
1802 : integer :: old_sz2, j, i
1803 475 : ierr = 0
1804 543 : select case(action)
1805 : case (do_deallocate)
1806 68 : if (associated(ptr)) then
1807 68 : deallocate(ptr)
1808 : nullify(ptr)
1809 : end if
1810 : case (do_allocate)
1811 132 : allocate(ptr(sz1, sz2), stat=ierr)
1812 66 : if (s% fill_arrays_with_NaNs) then
1813 0 : call set_nan(ptr)
1814 66 : else if (s% zero_when_allocate) then
1815 0 : ptr(1:sz1,1:sz2) = 0
1816 : end if
1817 : case (do_check_size)
1818 341 : if (size(ptr,dim=1) /= sz1) ierr = -1
1819 341 : if (size(ptr,dim=2) < sz2) ierr = -1
1820 : case (do_remove_from_center)
1821 0 : allocate(ptr2(sz1, sz2), stat=ierr)
1822 0 : old_sz2 = size(ptr,dim=2)
1823 0 : do j=1,min(old_sz2,sz2)
1824 0 : do i=1,sz1
1825 0 : ptr2(i,j) = ptr(i,j)
1826 : end do
1827 : end do
1828 0 : deallocate(ptr)
1829 0 : if (ierr /= 0) return
1830 0 : ptr => ptr2
1831 : case (do_reallocate)
1832 0 : if (associated(ptr)) then
1833 0 : if (size(ptr,dim=1) /= sz1) then
1834 0 : ierr = -1
1835 0 : return
1836 : end if
1837 0 : if (size(ptr,dim=2) >= sz2) return
1838 : else
1839 0 : ierr = -1
1840 0 : return
1841 : end if
1842 0 : allocate(ptr2(sz1, sz2), stat=ierr)
1843 0 : old_sz2 = size(ptr,dim=2)
1844 0 : do j=1,old_sz2
1845 0 : do i=1,sz1
1846 0 : ptr2(i,j) = ptr(i,j)
1847 : end do
1848 : end do
1849 0 : if (s% fill_arrays_with_NaNs) then
1850 0 : do j=old_sz2+1,sz2
1851 0 : do i=1,sz1
1852 0 : call set_nan(ptr2(i,j))
1853 : end do
1854 : end do
1855 0 : else if (s% zero_when_allocate) then
1856 0 : do j=old_sz2+1,sz2
1857 0 : do i=1,sz1
1858 0 : ptr2(i,j) = 0
1859 : end do
1860 : end do
1861 : end if
1862 0 : deallocate(ptr)
1863 0 : if (ierr /= 0) return
1864 0 : ptr => ptr2
1865 : case (do_fill_arrays_with_NaNs)
1866 0 : if (associated(ptr)) call set_nan(ptr)
1867 : end select
1868 475 : end subroutine do2D
1869 :
1870 :
1871 0 : subroutine do2D_quad(s, ptr, sz1, sz2, action, ierr)
1872 : type (star_info), pointer :: s
1873 : real(qp), dimension(:,:), pointer:: ptr
1874 : integer, intent(in) :: sz1, sz2, action
1875 : integer, intent(out) :: ierr
1876 0 : real(qp), dimension(:,:), pointer :: ptr2
1877 : integer :: old_sz2, j, i
1878 0 : ierr = 0
1879 0 : select case(action)
1880 : case (do_deallocate)
1881 0 : if (associated(ptr)) then
1882 0 : deallocate(ptr)
1883 : nullify(ptr)
1884 : end if
1885 : case (do_allocate)
1886 0 : allocate(ptr(sz1, sz2), stat=ierr)
1887 0 : if (s% zero_when_allocate) ptr = 0
1888 : case (do_check_size)
1889 0 : if (size(ptr,dim=1) /= sz1) ierr = -1
1890 0 : if (size(ptr,dim=2) < sz2) ierr = -1
1891 : case (do_remove_from_center)
1892 0 : allocate(ptr2(sz1, sz2), stat=ierr)
1893 0 : old_sz2 = size(ptr,dim=2)
1894 0 : do i=1,sz1
1895 0 : do j=1,min(old_sz2,sz2)
1896 0 : ptr2(i,j) = ptr(i,j)
1897 : end do
1898 : end do
1899 0 : deallocate(ptr)
1900 0 : if (ierr /= 0) return
1901 0 : ptr => ptr2
1902 : case (do_reallocate)
1903 0 : if (associated(ptr)) then
1904 0 : if (size(ptr,dim=1) /= sz1) then
1905 0 : ierr = -1
1906 0 : return
1907 : end if
1908 0 : if (size(ptr,dim=2) >= sz2) return
1909 : else
1910 0 : ierr = -1
1911 0 : return
1912 : end if
1913 0 : allocate(ptr2(sz1, sz2), stat=ierr)
1914 0 : old_sz2 = size(ptr,dim=2)
1915 0 : do j=1,old_sz2
1916 0 : do i=1,sz1
1917 0 : ptr2(i,j) = ptr(i,j)
1918 : end do
1919 : end do
1920 0 : deallocate(ptr)
1921 0 : if (ierr /= 0) return
1922 0 : ptr => ptr2
1923 : end select
1924 0 : end subroutine do2D_quad
1925 :
1926 :
1927 3 : subroutine do2D_dim1(s, ptr, sz1, sz2, action, ierr)
1928 :
1929 : type (star_info), pointer :: s
1930 : real(dp), dimension(:,:), pointer:: ptr
1931 : integer, intent(in) :: sz1, sz2, action
1932 : integer, intent(out) :: ierr
1933 3 : real(dp), dimension(:,:), pointer :: ptr2
1934 : integer :: old_sz1, j,i
1935 3 : ierr = 0
1936 5 : select case(action)
1937 : case (do_deallocate)
1938 2 : if (associated(ptr)) then
1939 1 : deallocate(ptr)
1940 : nullify(ptr)
1941 : end if
1942 : case (do_allocate)
1943 2 : allocate(ptr(sz1, sz2), stat=ierr)
1944 1 : if (s% fill_arrays_with_NaNs) then
1945 0 : call set_nan(ptr)
1946 1 : else if (s% zero_when_allocate) then
1947 0 : ptr(1:sz1,1:sz2) = 0
1948 : end if
1949 : case (do_remove_from_center)
1950 0 : allocate(ptr2(sz1, sz2), stat=ierr)
1951 0 : old_sz1 = size(ptr,dim=1)
1952 0 : do j=1,sz2
1953 0 : do i=1,min(old_sz1,sz1)
1954 0 : ptr2(i,j) = ptr(i,j)
1955 : end do
1956 : end do
1957 0 : deallocate(ptr)
1958 0 : if (ierr /= 0) return
1959 0 : ptr => ptr2
1960 : end select
1961 3 : end subroutine do2D_dim1
1962 :
1963 :
1964 30 : subroutine do3D(s, ptr, sz1, sz2, sz3, action, ierr)
1965 :
1966 : type (star_info), pointer :: s
1967 : real(dp), dimension(:,:,:), pointer:: ptr
1968 : integer, intent(in) :: sz1, sz2, sz3, action
1969 : integer, intent(out) :: ierr
1970 30 : real(dp), dimension(:,:,:), pointer :: ptr2
1971 : integer :: old_sz3, j, i, k
1972 30 : ierr = 0
1973 34 : select case(action)
1974 : case (do_deallocate)
1975 4 : if (associated(ptr)) then
1976 4 : deallocate(ptr)
1977 : nullify(ptr)
1978 : end if
1979 : case (do_allocate)
1980 12 : allocate(ptr(sz1, sz2, sz3), stat=ierr)
1981 4 : if (s% fill_arrays_with_NaNs) then
1982 0 : call set_nan(ptr)
1983 4 : else if (s% zero_when_allocate) then
1984 0 : ptr(1:sz1,1:sz2,1:sz3) = 0
1985 : end if
1986 : case (do_check_size)
1987 22 : if (size(ptr,dim=1) /= sz1) ierr = -1
1988 22 : if (size(ptr,dim=2) /= sz2) ierr = -1
1989 22 : if (size(ptr,dim=3) < sz3) ierr = -1
1990 : case (do_remove_from_center)
1991 0 : allocate(ptr2(sz1, sz2, sz3), stat=ierr)
1992 0 : old_sz3 = size(ptr,dim=3)
1993 0 : do k=1,min(old_sz3,sz3)
1994 0 : do j=1,sz2
1995 0 : do i=1,sz1
1996 0 : ptr2(i,j,k) = ptr(i,j,k)
1997 : end do
1998 : end do
1999 : end do
2000 0 : deallocate(ptr)
2001 0 : if (ierr /= 0) return
2002 0 : ptr => ptr2
2003 : case (do_reallocate)
2004 0 : if (associated(ptr)) then
2005 0 : if (size(ptr,dim=1) /= sz1 .or. size(ptr,dim=2) /= sz2) then
2006 0 : ierr = -1
2007 0 : return
2008 : end if
2009 0 : if (size(ptr,dim=3) >= sz3) return
2010 : else
2011 0 : ierr = -1
2012 0 : return
2013 : end if
2014 0 : allocate(ptr2(sz1, sz2, sz3), stat=ierr)
2015 0 : old_sz3 = size(ptr,dim=3)
2016 0 : do k=1,old_sz3
2017 0 : do j=1,sz2
2018 0 : do i=1,sz1
2019 0 : ptr2(i,j,k) = ptr(i,j,k)
2020 : end do
2021 : end do
2022 : end do
2023 0 : if (s% fill_arrays_with_NaNs) then
2024 0 : do k=old_sz3+1,sz3
2025 0 : do j=1,sz2
2026 0 : do i=1,sz1
2027 0 : call set_nan(ptr2(i,j,k))
2028 : end do
2029 : end do
2030 : end do
2031 0 : else if (s% zero_when_allocate) then
2032 0 : do k=old_sz3+1,sz3
2033 0 : do j=1,sz2
2034 0 : do i=1,sz1
2035 0 : ptr2(i,j,k) = 0
2036 : end do
2037 : end do
2038 : end do
2039 : end if
2040 0 : deallocate(ptr)
2041 0 : if (ierr /= 0) return
2042 0 : ptr => ptr2
2043 : case (do_fill_arrays_with_NaNs)
2044 0 : if (associated(ptr)) call set_nan(ptr)
2045 : end select
2046 30 : end subroutine do3D
2047 :
2048 :
2049 0 : subroutine do4D(s, ptr, sz1, sz2, sz3, sz4, action, ierr)
2050 :
2051 : type (star_info), pointer :: s
2052 : real(dp), dimension(:,:,:,:), pointer:: ptr
2053 : integer, intent(in) :: sz1, sz2, sz3, sz4, action
2054 : integer, intent(out) :: ierr
2055 0 : real(dp), dimension(:,:,:,:), pointer :: ptr2
2056 : integer :: old_sz4, i, j, k, m
2057 0 : ierr = 0
2058 0 : select case(action)
2059 : case (do_deallocate)
2060 0 : if (associated(ptr)) then
2061 0 : deallocate(ptr)
2062 : nullify(ptr)
2063 : end if
2064 : case (do_allocate)
2065 0 : allocate(ptr(sz1, sz2, sz3, sz4), stat=ierr)
2066 0 : if (s% fill_arrays_with_NaNs) then
2067 0 : call set_nan(ptr)
2068 0 : else if (s% zero_when_allocate) then
2069 0 : ptr(1:sz1,1:sz2,1:sz3,1:sz4) = 0
2070 : end if
2071 : case (do_check_size)
2072 0 : if (size(ptr,dim=1) /= sz1) ierr = -1
2073 0 : if (size(ptr,dim=2) /= sz2) ierr = -1
2074 0 : if (size(ptr,dim=3) /= sz3) ierr = -1
2075 0 : if (size(ptr,dim=4) < sz4) ierr = -1
2076 : case (do_remove_from_center)
2077 0 : allocate(ptr2(sz1, sz2, sz3, sz4), stat=ierr)
2078 0 : old_sz4 = size(ptr,dim=4)
2079 0 : do m=1,min(old_sz4,sz4)
2080 0 : do k=1,sz3
2081 0 : do j=1,sz2
2082 0 : do i=1,sz1
2083 0 : ptr2(i,j,k,m) = ptr(i,j,k,m)
2084 : end do
2085 : end do
2086 : end do
2087 : end do
2088 0 : deallocate(ptr)
2089 0 : if (ierr /= 0) return
2090 0 : ptr => ptr2
2091 : case (do_reallocate)
2092 0 : if (associated(ptr)) then
2093 : if (size(ptr,dim=1) /= sz1 .or. &
2094 0 : size(ptr,dim=2) /= sz2 .or. &
2095 : size(ptr,dim=3) /= sz3) then
2096 0 : ierr = -1
2097 0 : return
2098 : end if
2099 0 : if (size(ptr,dim=4) >= sz4) return
2100 : else
2101 0 : ierr = -1
2102 0 : return
2103 : end if
2104 0 : allocate(ptr2(sz1, sz2, sz3, sz4), stat=ierr)
2105 0 : old_sz4 = size(ptr,dim=4)
2106 0 : do m=1,old_sz4
2107 0 : do k=1,sz3
2108 0 : do j=1,sz2
2109 0 : do i=1,sz1
2110 0 : ptr2(i,j,k,m) = ptr(i,j,k,m)
2111 : end do
2112 : end do
2113 : end do
2114 : end do
2115 0 : if (s% fill_arrays_with_NaNs) then
2116 0 : do m=old_sz4+1,sz4
2117 0 : do k=1,sz3
2118 0 : do j=1,sz2
2119 0 : do i=1,sz1
2120 0 : call set_nan(ptr2(i,j,k,m))
2121 : end do
2122 : end do
2123 : end do
2124 : end do
2125 0 : else if (s% zero_when_allocate) then
2126 0 : do m=old_sz4+1,sz4
2127 0 : do k=1,sz3
2128 0 : do j=1,sz2
2129 0 : do i=1,sz1
2130 0 : ptr2(i,j,k,m) = 0
2131 : end do
2132 : end do
2133 : end do
2134 : end do
2135 : end if
2136 0 : deallocate(ptr)
2137 0 : if (ierr /= 0) return
2138 0 : ptr => ptr2
2139 : case (do_fill_arrays_with_NaNs)
2140 0 : call set_nan(ptr)
2141 : end select
2142 0 : end subroutine do4D
2143 :
2144 :
2145 165 : subroutine do1D_integer(s, ptr, sz, action, ierr)
2146 : type (star_info), pointer :: s
2147 : integer, dimension(:), pointer:: ptr
2148 : integer, intent(in) :: sz, action
2149 : integer, intent(out) :: ierr
2150 165 : integer, dimension(:), pointer :: ptr2
2151 : integer :: old_sz, j
2152 165 : ierr = 0
2153 187 : select case(action)
2154 : case (do_deallocate)
2155 22 : if (associated(ptr)) then
2156 22 : deallocate(ptr)
2157 : nullify(ptr)
2158 : end if
2159 : case (do_allocate)
2160 22 : allocate(ptr(sz), stat=ierr)
2161 22 : if (s% zero_when_allocate) ptr = 0
2162 : case (do_check_size)
2163 121 : if (size(ptr,dim=1) < sz) ierr = -1
2164 : case (do_remove_from_center)
2165 0 : allocate(ptr2(sz), stat=ierr)
2166 0 : old_sz = size(ptr,dim=1)
2167 0 : do j=1,min(old_sz,sz)
2168 0 : ptr2(j) = ptr(j)
2169 : end do
2170 0 : deallocate(ptr)
2171 0 : if (ierr /= 0) return
2172 0 : ptr => ptr2
2173 : case (do_reallocate)
2174 0 : if (associated(ptr)) then
2175 0 : if (size(ptr,dim=1) >= sz) return
2176 : else
2177 0 : ierr = -1
2178 0 : return
2179 : end if
2180 0 : allocate(ptr2(sz), stat=ierr)
2181 0 : old_sz = size(ptr,dim=1)
2182 0 : do j=1,old_sz
2183 0 : ptr2(j) = ptr(j)
2184 : end do
2185 0 : deallocate(ptr)
2186 0 : if (ierr /= 0) return
2187 0 : ptr => ptr2
2188 : end select
2189 165 : end subroutine do1D_integer
2190 :
2191 :
2192 0 : subroutine do2D_integer(s, ptr, sz1, sz2, action, ierr)
2193 : type (star_info), pointer :: s
2194 : integer, dimension(:, :), pointer:: ptr
2195 : integer, intent(in) :: sz1, sz2, action
2196 : integer, intent(out) :: ierr
2197 0 : integer, dimension(:,:), pointer :: ptr2
2198 : integer :: old_sz2, j, i
2199 0 : ierr = 0
2200 0 : select case(action)
2201 : case (do_deallocate)
2202 0 : if (associated(ptr)) then
2203 0 : deallocate(ptr)
2204 : nullify(ptr)
2205 : end if
2206 : case (do_allocate)
2207 0 : allocate(ptr(sz1, sz2), stat=ierr)
2208 0 : if (s% zero_when_allocate) ptr = 0
2209 : case (do_check_size)
2210 0 : if (size(ptr,dim=1) /= sz1) ierr = -1
2211 0 : if (size(ptr,dim=2) < sz2) ierr = -1
2212 : case (do_remove_from_center)
2213 0 : allocate(ptr2(sz1, sz2), stat=ierr)
2214 0 : old_sz2 = size(ptr,dim=2)
2215 0 : do j=1,min(old_sz2,sz2)
2216 0 : do i=1,sz1
2217 0 : ptr2(i,j) = ptr(i,j)
2218 : end do
2219 : end do
2220 0 : deallocate(ptr)
2221 0 : if (ierr /= 0) return
2222 0 : ptr => ptr2
2223 : case (do_reallocate)
2224 0 : if (associated(ptr)) then
2225 0 : if (size(ptr,dim=1) /= sz1) then
2226 0 : ierr = -1
2227 0 : return
2228 : end if
2229 0 : if (size(ptr,dim=2) >= sz2) return
2230 : else
2231 0 : ierr = -1
2232 0 : return
2233 : end if
2234 0 : allocate(ptr2(sz1, sz2), stat=ierr)
2235 0 : old_sz2 = size(ptr,dim=2)
2236 0 : do j=1,old_sz2
2237 0 : do i=1,sz1
2238 0 : ptr2(i,j) = ptr(i,j)
2239 : end do
2240 : end do
2241 0 : deallocate(ptr)
2242 0 : if (ierr /= 0) return
2243 0 : ptr => ptr2
2244 : end select
2245 0 : end subroutine do2D_integer
2246 :
2247 :
2248 30 : subroutine do1D_logical(s, ptr, sz, action, ierr)
2249 : type (star_info), pointer :: s
2250 : logical, dimension(:), pointer:: ptr
2251 : integer, intent(in) :: sz, action
2252 : integer, intent(out) :: ierr
2253 30 : logical, dimension(:), pointer :: ptr2
2254 : integer :: old_sz, j
2255 30 : ierr = 0
2256 34 : select case(action)
2257 : case (do_deallocate)
2258 4 : if (associated(ptr)) then
2259 4 : deallocate(ptr)
2260 : nullify(ptr)
2261 : end if
2262 : case (do_allocate)
2263 4 : allocate(ptr(sz), stat=ierr)
2264 4 : if (s% zero_when_allocate) ptr = .false.
2265 : case (do_check_size)
2266 22 : if (size(ptr,dim=1) < sz) ierr = -1
2267 : case (do_remove_from_center)
2268 0 : allocate(ptr2(sz), stat=ierr)
2269 0 : old_sz = size(ptr,dim=1)
2270 0 : do j=1,min(old_sz,sz)
2271 0 : ptr2(j) = ptr(j)
2272 : end do
2273 0 : deallocate(ptr)
2274 0 : if (ierr /= 0) return
2275 0 : ptr => ptr2
2276 : case (do_reallocate)
2277 0 : if (associated(ptr)) then
2278 0 : if (size(ptr,dim=1) >= sz) return
2279 : else
2280 0 : ierr = -1
2281 0 : return
2282 : end if
2283 0 : allocate(ptr2(sz), stat=ierr)
2284 0 : old_sz = size(ptr,dim=1)
2285 0 : do j=1,old_sz
2286 0 : ptr2(j) = ptr(j)
2287 : end do
2288 0 : deallocate(ptr)
2289 0 : if (ierr /= 0) return
2290 0 : ptr => ptr2
2291 : end select
2292 30 : end subroutine do1D_logical
2293 :
2294 :
2295 1 : subroutine set_var_info(s, ierr)
2296 : type (star_info), pointer :: s
2297 : integer, intent(out) :: ierr
2298 :
2299 : integer :: i
2300 :
2301 : include 'formats'
2302 :
2303 1 : ierr = 0
2304 : i = 0
2305 :
2306 : ! first assign variable numbers
2307 1 : i = i+1; s% i_lnd = i
2308 1 : i = i+1; s% i_lnT = i
2309 1 : i = i+1; s% i_lnR = i
2310 :
2311 1 : if (.not. s% RSP_flag) then
2312 1 : i = i+1; s% i_lum = i
2313 : else
2314 0 : s% i_lum = 0
2315 : end if
2316 :
2317 1 : if (s% v_flag) then
2318 0 : i = i+1; s% i_v = i
2319 : else
2320 1 : s% i_v = 0
2321 : end if
2322 :
2323 1 : if (s% u_flag) then
2324 0 : i = i+1;s% i_u = i
2325 : else
2326 1 : s% i_u = 0
2327 : end if
2328 :
2329 1 : if (s% RTI_flag) then
2330 0 : i = i+1; s% i_alpha_RTI = i
2331 : else
2332 1 : s% i_alpha_RTI = 0
2333 : end if
2334 :
2335 1 : if (s% RSP_flag) then
2336 0 : i = i+1; s% i_Et_RSP = i
2337 0 : i = i+1; s% i_erad_RSP = i
2338 0 : i = i+1; s% i_Fr_RSP = i
2339 : else
2340 1 : s% i_Et_RSP = 0
2341 1 : s% i_erad_RSP = 0
2342 1 : s% i_Fr_RSP = 0
2343 : end if
2344 :
2345 1 : if (s% RSP2_flag) then
2346 0 : i = i+1; s% i_w = i
2347 0 : i = i+1; s% i_Hp = i
2348 : else
2349 1 : s% i_w = 0
2350 1 : s% i_Hp = 0
2351 : end if
2352 :
2353 1 : if (s% w_div_wc_flag) then
2354 0 : i = i+1; s% i_w_div_wc = i
2355 : else
2356 1 : s% i_w_div_wc = 0
2357 : end if
2358 :
2359 1 : if (s% j_rot_flag) then
2360 0 : i = i+1; s% i_j_rot = i
2361 : else
2362 1 : s% i_j_rot = 0
2363 : end if
2364 :
2365 : ! now assign equation numbers
2366 1 : if (s% i_v /= 0 .or. s% i_u /= 0) then
2367 0 : s% i_dlnd_dt = s% i_lnd
2368 0 : s% i_dlnE_dt = s% i_lnT
2369 0 : s% i_equL = s% i_lum
2370 0 : s% i_dlnR_dt = s% i_lnR
2371 0 : s% i_dv_dt = s% i_v
2372 0 : s% i_du_dt = s% i_u
2373 : else ! HSE is included in dv_dt, so drop dlnR_dt
2374 1 : s% i_equL = s% i_lnd
2375 1 : s% i_dv_dt = s% i_lnT
2376 1 : s% i_dlnE_dt = s% i_lum
2377 1 : s% i_dlnd_dt = s% i_lnR
2378 1 : s% i_dlnR_dt = 0
2379 1 : s% i_du_dt = 0
2380 : end if
2381 :
2382 1 : s% i_detrb_dt = s% i_w
2383 1 : s% i_equ_Hp = s% i_Hp
2384 1 : s% i_dalpha_RTI_dt = s% i_alpha_RTI
2385 1 : s% i_dEt_RSP_dt = s% i_Et_RSP
2386 1 : s% i_derad_RSP_dt = s% i_erad_RSP
2387 1 : s% i_dFr_RSP_dt = s% i_Fr_RSP
2388 1 : s% i_equ_w_div_wc = s% i_w_div_wc
2389 1 : s% i_dj_rot_dt = s% i_j_rot
2390 :
2391 1 : s% nvar_hydro = i
2392 1 : s% nvar_total = s% nvar_hydro + s% nvar_chem
2393 :
2394 : ! Names of the variables
2395 1 : if (s% i_lnd /= 0) s% nameofvar(s% i_lnd) = 'lnd'
2396 1 : if (s% i_lnT /= 0) s% nameofvar(s% i_lnT) = 'lnT'
2397 1 : if (s% i_lnR /= 0) s% nameofvar(s% i_lnR) = 'lnR'
2398 1 : if (s% i_lum /= 0) s% nameofvar(s% i_lum) = 'L'
2399 1 : if (s% i_v /= 0) s% nameofvar(s% i_v) = 'v'
2400 1 : if (s% i_w /= 0) s% nameofvar(s% i_w) = 'w'
2401 1 : if (s% i_Hp/= 0) s% nameofvar(s% i_Hp) = 'Hp'
2402 1 : if (s% i_alpha_RTI /= 0) s% nameofvar(s% i_alpha_RTI) = 'alpha_RTI'
2403 1 : if (s% i_Et_RSP /= 0) s% nameofvar(s% i_Et_RSP) = 'etrb_RSP'
2404 1 : if (s% i_erad_RSP /= 0) s% nameofvar(s% i_erad_RSP) = 'erad_RSP'
2405 1 : if (s% i_Fr_RSP /= 0) s% nameofvar(s% i_Fr_RSP) = 'Fr_RSP'
2406 1 : if (s% i_w_div_wc /= 0) s% nameofvar(s% i_w_div_wc) = 'w_div_wc'
2407 1 : if (s% i_j_rot /= 0) s% nameofvar(s% i_j_rot) = 'j_rot'
2408 1 : if (s% i_u /= 0) s% nameofvar(s% i_u) = 'u'
2409 :
2410 : ! Names of the equations
2411 1 : if (s% i_dv_dt /= 0) s% nameofequ(s% i_dv_dt) = 'dv_dt'
2412 1 : if (s% i_equL /= 0) s% nameofequ(s% i_equL) = 'equL'
2413 1 : if (s% i_dlnd_dt /= 0) s% nameofequ(s% i_dlnd_dt) = 'dlnd_dt'
2414 1 : if (s% i_dlnE_dt /= 0) s% nameofequ(s% i_dlnE_dt) = 'dlnE_dt'
2415 1 : if (s% i_dlnR_dt /= 0) s% nameofequ(s% i_dlnR_dt) = 'dlnR_dt'
2416 1 : if (s% i_detrb_dt /= 0) s% nameofequ(s% i_detrb_dt) = 'detrb_dt'
2417 1 : if (s% i_equ_Hp /= 0) s% nameofequ(s% i_equ_Hp) = 'equ_Hp'
2418 1 : if (s% i_dalpha_RTI_dt /= 0) s% nameofequ(s% i_dalpha_RTI_dt) = 'dalpha_RTI_dt'
2419 1 : if (s% i_dEt_RSP_dt /= 0) s% nameofequ(s% i_dEt_RSP_dt) = 'dEt_RSP_dt'
2420 1 : if (s% i_derad_RSP_dt /= 0) s% nameofequ(s% i_derad_RSP_dt) = 'derad_RSP_dt'
2421 1 : if (s% i_dFr_RSP_dt /= 0) s% nameofequ(s% i_dFr_RSP_dt) = 'dFr_RSP_dt'
2422 1 : if (s% i_equ_w_div_wc /= 0) s% nameofequ(s% i_equ_w_div_wc) = 'equ_w_div_wc'
2423 1 : if (s% i_dj_rot_dt /= 0) s% nameofequ(s% i_dj_rot_dt) = 'dj_rot_dt'
2424 1 : if (s% i_du_dt /= 0) s% nameofequ(s% i_du_dt) = 'du_dt'
2425 :
2426 : ! chem names are done later by set_chem_names when have set up the net
2427 :
2428 :
2429 1 : s% need_to_setvars = .true.
2430 :
2431 1 : end subroutine set_var_info
2432 :
2433 :
2434 1 : subroutine set_chem_names(s)
2435 : use chem_def
2436 : type (star_info), pointer :: s
2437 : integer :: old_size, i, j, cid
2438 :
2439 : include 'formats'
2440 :
2441 1 : if (s% nvar_hydro == 0) return ! not ready to set chem names yet
2442 :
2443 1 : old_size = size(s% nameofvar,dim=1)
2444 1 : if (old_size < s% nvar_total) then
2445 0 : call realloc(s% nameofvar)
2446 0 : call realloc(s% nameofequ)
2447 : end if
2448 10 : do i=1, s% nvar_chem
2449 8 : cid = s% chem_id(i)
2450 8 : j = s% nvar_hydro+i
2451 8 : s% nameofvar(j) = trim(chem_isos% name(cid))
2452 9 : s% nameofequ(j) = 'equ_' // trim(chem_isos% name(cid))
2453 : end do
2454 :
2455 : contains
2456 :
2457 0 : subroutine realloc(p)
2458 : character (len=name_len), dimension(:), pointer :: p
2459 0 : character (len=name_len), dimension(:), pointer :: old_p
2460 : integer :: cpy_len, j
2461 0 : old_p => p
2462 0 : old_size = size(p,dim=1)
2463 0 : allocate(p(s% nvar_total))
2464 0 : cpy_len = min(old_size, s% nvar_total)
2465 0 : do j=1,cpy_len
2466 0 : p(j) = old_p(j)
2467 : end do
2468 0 : deallocate(old_p)
2469 1 : end subroutine realloc
2470 :
2471 : subroutine realloc_logical(p)
2472 : logical, dimension(:), pointer :: p
2473 : logical, dimension(:), pointer :: old_p
2474 : integer :: cpy_len, j
2475 : old_p => p
2476 : old_size = size(p,dim=1)
2477 : allocate(p(s% nvar_total))
2478 : cpy_len = min(old_size, s% nvar_total)
2479 : do j=1,cpy_len
2480 : p(j) = old_p(j)
2481 : end do
2482 : deallocate(old_p)
2483 : end subroutine realloc_logical
2484 :
2485 : end subroutine set_chem_names
2486 :
2487 :
2488 0 : subroutine realloc_work_array(s, crit, ptr, oldsz, newsz, extra, str, ierr)
2489 : type (star_info), pointer :: s
2490 : logical, intent(in) :: crit
2491 : integer, intent(in) :: oldsz, newsz, extra
2492 : real(dp), pointer :: ptr(:)
2493 : character (len=*), intent(in) :: str
2494 : integer, intent(out) :: ierr
2495 : real(dp), pointer :: tmp(:)
2496 : integer :: k
2497 0 : tmp => ptr
2498 0 : call work_array(s, .true., crit, ptr, newsz, extra, str, ierr)
2499 0 : if (ierr /= 0) return
2500 0 : do k=1,min(oldsz,newsz)
2501 0 : ptr(k) = tmp(k)
2502 : end do
2503 0 : call work_array(s, .false., crit, tmp, newsz, extra, str, ierr)
2504 : end subroutine realloc_work_array
2505 :
2506 : ! if alloc is false, then deallocate ptr
2507 : ! if crit is false, then don't need reentrant allocation
2508 424 : subroutine work_array(s, alloc, crit, ptr, sz, extra, str, ierr)
2509 : type (star_info), pointer :: s
2510 : logical, intent(in) :: alloc, crit
2511 : integer, intent(in) :: sz, extra
2512 : real(dp), pointer :: ptr(:)
2513 : character (len=*), intent(in) :: str
2514 : integer, intent(out) :: ierr
2515 424 : ierr = 0
2516 424 : if (alloc) then
2517 212 : call do_get_work_array(s, crit, ptr, sz, extra, str, ierr)
2518 : else
2519 212 : call do_return_work_array(s, crit, ptr, str)
2520 : end if
2521 424 : end subroutine work_array
2522 :
2523 :
2524 212 : subroutine do_get_work_array(s, crit, ptr, sz, extra, str, ierr)
2525 : type (star_info), pointer :: s
2526 : logical, intent(in) :: crit
2527 : integer, intent(in) :: sz, extra
2528 : real(dp), pointer :: ptr(:)
2529 : character (len=*), intent(in) :: str
2530 : integer, intent(out) :: ierr
2531 :
2532 : integer :: i
2533 : logical :: okay
2534 :
2535 212 : ierr = 0
2536 :
2537 : if (work_array_debug) then
2538 : allocate(ptr(sz + extra), stat=ierr)
2539 : if (s% fill_arrays_with_NaNs) call set_nan(ptr)
2540 204 : return
2541 : end if
2542 :
2543 212 : okay = .false.
2544 :
2545 212 : if (crit) then
2546 0 : !$omp critical (alloc_work_array1)
2547 0 : num_calls = num_calls + 1 ! not safe, but just for info
2548 0 : do i = 1, num_work_arrays
2549 0 : if (get1(i)) then
2550 : okay = .true.
2551 : exit
2552 : end if
2553 : end do
2554 : !$omp end critical (alloc_work_array1)
2555 : else
2556 212 : num_calls = num_calls + 1
2557 2596 : do i = 1, num_work_arrays
2558 2596 : if (get1(i)) then
2559 : okay = .true.
2560 : exit
2561 : end if
2562 : end do
2563 : end if
2564 212 : if (okay) return
2565 :
2566 8 : allocate(ptr(sz + extra), stat=ierr)
2567 8 : num_allocs = num_allocs + 1
2568 8 : if (s% fill_arrays_with_NaNs) then
2569 0 : call set_nan(ptr)
2570 8 : else if (s% zero_when_allocate) then
2571 0 : ptr(:) = 0
2572 : end if
2573 :
2574 : if (work_array_trace) write(*,*) 'allocate new work array'
2575 :
2576 : contains
2577 :
2578 2588 : logical function get1(itry)
2579 : integer, intent(in) :: itry
2580 2588 : real(dp), pointer :: p(:)
2581 : include 'formats'
2582 2588 : if (.not. associated(work_pointers(itry)% p)) then
2583 2588 : get1 = .false.
2584 : return
2585 : end if
2586 204 : p => work_pointers(itry)% p
2587 204 : work_pointers(itry)% p => null()
2588 204 : if (size(p,dim=1) < sz) then
2589 : if (work_array_trace) &
2590 : write(*,4) 'enlarge work array ' // trim(str), &
2591 : itry, size(p,dim=1), sz + extra
2592 6 : deallocate(p)
2593 6 : allocate(p(sz + extra), stat=ierr)
2594 : else
2595 : if (work_array_trace) &
2596 : write(*,4) 'use work array ' // trim(str), itry, size(p,dim=1)
2597 : end if
2598 204 : ptr => p
2599 204 : get1 = .true.
2600 204 : if (s% fill_arrays_with_NaNs) then
2601 0 : call set_nan(ptr)
2602 204 : else if (s% zero_when_allocate) then
2603 0 : ptr(:) = 0
2604 : end if
2605 2588 : end function get1
2606 :
2607 : end subroutine do_get_work_array
2608 :
2609 :
2610 212 : subroutine do_return_work_array(s, crit, ptr, str)
2611 : type (star_info), pointer :: s
2612 : logical, intent(in) :: crit
2613 : real(dp), pointer :: ptr(:)
2614 : character (len=*), intent(in) :: str
2615 :
2616 : integer :: i
2617 : logical :: okay
2618 :
2619 212 : if (.not. associated(ptr)) then
2620 : !write(*,*) 'bogus call on do_return_work_array with nil ptr ' // trim(str)
2621 : !call mesa_error(__FILE__,__LINE__,'do_return_work_array')
2622 212 : return
2623 : end if
2624 :
2625 : if (work_array_debug) then
2626 : deallocate(ptr)
2627 : return
2628 : end if
2629 :
2630 212 : okay = .false.
2631 212 : if (crit) then
2632 0 : !$omp critical (alloc_work_array2)
2633 0 : num_returns = num_returns + 1
2634 0 : do i=1,num_work_arrays
2635 0 : if (return1(i)) then
2636 : okay = .true.
2637 : exit
2638 : end if
2639 : end do
2640 : !$omp end critical (alloc_work_array2)
2641 : else
2642 212 : num_returns = num_returns + 1
2643 624 : do i=1,num_work_arrays
2644 624 : if (return1(i)) then
2645 : okay = .true.
2646 : exit
2647 : end if
2648 : end do
2649 : end if
2650 212 : if (okay) return
2651 :
2652 0 : deallocate(ptr)
2653 0 : num_deallocs = num_deallocs + 1
2654 :
2655 : contains
2656 :
2657 624 : logical function return1(itry)
2658 : integer, intent(in) :: itry
2659 : include 'formats'
2660 624 : if (associated(work_pointers(itry)% p)) then
2661 624 : return1 = .false.
2662 : return
2663 : end if
2664 : if (work_array_trace) &
2665 : write(*,3) 'return work array ' // trim(str), itry, size(ptr,dim=1)
2666 212 : work_pointers(itry)% p => ptr
2667 212 : ptr => null()
2668 212 : return1 = .true.
2669 212 : end function return1
2670 :
2671 : end subroutine do_return_work_array
2672 :
2673 :
2674 0 : subroutine get_quad_array(s, ptr, sz, extra, str, ierr)
2675 : type (star_info), pointer :: s
2676 : integer, intent(in) :: sz, extra
2677 : real(qp), pointer :: ptr(:)
2678 : character (len=*), intent(in) :: str
2679 : integer, intent(out) :: ierr
2680 0 : call do_get_quad_array(s, .true., ptr, sz, extra, str, ierr)
2681 0 : end subroutine get_quad_array
2682 :
2683 :
2684 : ! okay to use this if sure don't need reentrant allocation
2685 0 : subroutine non_crit_get_quad_array(s, ptr, sz, extra, str, ierr)
2686 : type (star_info), pointer :: s
2687 : integer, intent(in) :: sz, extra
2688 : real(qp), pointer :: ptr(:)
2689 : character (len=*), intent(in) :: str
2690 : integer, intent(out) :: ierr
2691 0 : call do_get_quad_array(s, .false., ptr, sz, extra, str, ierr)
2692 0 : end subroutine non_crit_get_quad_array
2693 :
2694 :
2695 0 : subroutine do_get_quad_array(s, crit, ptr, sz, extra, str, ierr)
2696 : type (star_info), pointer :: s
2697 : logical, intent(in) :: crit
2698 : integer, intent(in) :: sz, extra
2699 : real(qp), pointer :: ptr(:)
2700 : character (len=*), intent(in) :: str
2701 : integer, intent(out) :: ierr
2702 :
2703 : integer :: i
2704 : logical :: okay
2705 :
2706 0 : ierr = 0
2707 :
2708 : if (quad_array_debug) then
2709 : allocate(ptr(sz + extra), stat=ierr)
2710 0 : return
2711 : end if
2712 :
2713 0 : okay = .false.
2714 0 : if (crit) then
2715 0 : !$omp critical (alloc_quad_work_array1)
2716 0 : num_calls = num_calls + 1
2717 0 : do i = 1, num_quad_arrays
2718 0 : if (get1(i)) then
2719 : okay = .true.
2720 : exit
2721 : end if
2722 : end do
2723 : !$omp end critical (alloc_quad_work_array1)
2724 : else
2725 0 : num_calls = num_calls + 1
2726 0 : do i = 1, num_quad_arrays
2727 0 : if (get1(i)) then
2728 : okay = .true.
2729 : exit
2730 : end if
2731 : end do
2732 : end if
2733 0 : if (okay) return
2734 :
2735 0 : allocate(ptr(sz + extra), stat=ierr)
2736 0 : num_allocs = num_allocs + 1
2737 :
2738 : if (quad_array_trace) write(*,*) 'allocate new quad array'
2739 :
2740 : contains
2741 :
2742 0 : logical function get1(itry)
2743 : integer, intent(in) :: itry
2744 0 : real(qp), pointer :: p(:)
2745 : include 'formats'
2746 0 : if (.not. associated(quad_pointers(itry)% p)) then
2747 0 : get1 = .false.
2748 : return
2749 : end if
2750 0 : p => quad_pointers(itry)% p
2751 0 : quad_pointers(itry)% p => null()
2752 0 : if (size(p,dim=1) < sz) then
2753 : if (quad_array_trace) &
2754 : write(*,4) 'enlarge quad array ' // trim(str), itry, size(p,dim=1), sz + extra
2755 0 : deallocate(p)
2756 0 : allocate(p(sz + extra), stat=ierr)
2757 : else
2758 : if (quad_array_trace) &
2759 : write(*,4) 'use quad array ' // trim(str), itry, size(p,dim=1)
2760 : end if
2761 0 : ptr => p
2762 0 : get1 = .true.
2763 0 : end function get1
2764 :
2765 : end subroutine do_get_quad_array
2766 :
2767 :
2768 0 : subroutine return_quad_array(s, ptr, str)
2769 : type (star_info), pointer :: s
2770 : real(qp), pointer :: ptr(:)
2771 : character (len=*), intent(in) :: str
2772 0 : call do_return_quad_array(s, .true., ptr, str)
2773 0 : end subroutine return_quad_array
2774 :
2775 :
2776 : ! okay to use this if sure don't need reentrant allocation
2777 0 : subroutine non_crit_return_quad_array(s, ptr, str)
2778 : type (star_info), pointer :: s
2779 : real(qp), pointer :: ptr(:)
2780 : character (len=*), intent(in) :: str
2781 0 : if (.not. associated(ptr)) return
2782 0 : call do_return_quad_array(s, .false., ptr, str)
2783 : end subroutine non_crit_return_quad_array
2784 :
2785 :
2786 0 : subroutine do_return_quad_array(s, crit, ptr, str)
2787 : type (star_info), pointer :: s
2788 : logical, intent(in) :: crit
2789 : real(qp), pointer :: ptr(:)
2790 : character (len=*), intent(in) :: str
2791 :
2792 : integer :: i
2793 : logical :: okay
2794 :
2795 0 : if (.not. associated(ptr)) return
2796 :
2797 : if (quad_array_debug) then
2798 : deallocate(ptr)
2799 : return
2800 : end if
2801 :
2802 0 : okay = .false.
2803 0 : if (crit) then
2804 0 : !$omp critical (alloc_quad_work_array2)
2805 0 : num_returns = num_returns + 1
2806 0 : do i=1,num_quad_arrays
2807 0 : if (return1(i)) then
2808 : okay = .true.
2809 : exit
2810 : end if
2811 : end do
2812 : !$omp end critical (alloc_quad_work_array2)
2813 : else
2814 0 : num_returns = num_returns + 1
2815 0 : do i=1,num_quad_arrays
2816 0 : if (return1(i)) then
2817 : okay = .true.
2818 : exit
2819 : end if
2820 : end do
2821 : end if
2822 0 : if (okay) return
2823 :
2824 0 : deallocate(ptr)
2825 0 : num_deallocs = num_deallocs + 1
2826 :
2827 : contains
2828 :
2829 0 : logical function return1(itry)
2830 : integer, intent(in) :: itry
2831 : include 'formats'
2832 0 : if (associated(quad_pointers(itry)% p)) then
2833 0 : return1 = .false.
2834 : return
2835 : end if
2836 : if (quad_array_trace) &
2837 : write(*,3) 'return quad array ' // trim(str), itry, size(ptr,dim=1)
2838 0 : quad_pointers(itry)% p => ptr
2839 0 : ptr => null()
2840 0 : return1 = .true.
2841 0 : end function return1
2842 :
2843 : end subroutine do_return_quad_array
2844 :
2845 :
2846 0 : subroutine realloc_integer_work_array(s, ptr, oldsz, newsz, extra, ierr)
2847 : type (star_info), pointer :: s
2848 : integer, intent(in) :: oldsz, newsz, extra
2849 : integer, pointer :: ptr(:)
2850 : integer, intent(out) :: ierr
2851 : integer, pointer :: itmp(:)
2852 : integer :: k
2853 0 : itmp => ptr
2854 0 : call get_integer_work_array(s, ptr, newsz, extra, ierr)
2855 0 : if (ierr /= 0) return
2856 0 : do k=1,min(oldsz,newsz)
2857 0 : ptr(k) = itmp(k)
2858 : end do
2859 0 : call return_integer_work_array(s, itmp)
2860 : end subroutine realloc_integer_work_array
2861 :
2862 :
2863 30 : subroutine get_integer_work_array(s, ptr, sz, extra, ierr)
2864 : type (star_info), pointer :: s
2865 : integer, intent(in) :: sz, extra
2866 : integer, pointer :: ptr(:)
2867 : integer, intent(out) :: ierr
2868 :
2869 : integer :: i
2870 : logical :: okay
2871 :
2872 30 : ierr = 0
2873 :
2874 : if (work_array_debug) then
2875 : allocate(ptr(sz + extra), stat=ierr)
2876 : return
2877 : end if
2878 :
2879 30 : okay = .false.
2880 60 : !$omp critical (alloc_integer_work_array1)
2881 30 : num_calls = num_calls + 1
2882 807 : do i=1,num_int_work_arrays
2883 807 : if (get1(i)) then
2884 : okay = .true.
2885 : exit
2886 : end if
2887 : end do
2888 : !$omp end critical (alloc_integer_work_array1)
2889 30 : if (okay) return
2890 :
2891 3 : allocate(ptr(sz + extra), stat=ierr)
2892 3 : num_allocs = num_allocs + 1
2893 :
2894 : if (work_array_trace) &
2895 : write(*,*) 'allocate new integer work array'
2896 :
2897 : contains
2898 :
2899 804 : logical function get1(itry)
2900 : integer, intent(in) :: itry
2901 804 : integer, pointer :: p(:)
2902 : include 'formats'
2903 804 : if (.not. associated(int_work_pointers(i)% p)) then
2904 804 : get1 = .false.
2905 : return
2906 : end if
2907 27 : p => int_work_pointers(i)% p
2908 27 : int_work_pointers(i)% p => null()
2909 27 : if (size(p,dim=1) < sz) then
2910 : if (work_array_trace) &
2911 : write(*,3) 'enlarge integer work array', size(p,dim=1), sz + extra
2912 0 : deallocate(p)
2913 0 : allocate(p(sz + extra), stat=ierr)
2914 : end if
2915 27 : ptr => p
2916 27 : get1 = .true.
2917 804 : end function get1
2918 :
2919 : end subroutine get_integer_work_array
2920 :
2921 :
2922 30 : subroutine return_integer_work_array(s, ptr)
2923 : type (star_info), pointer :: s
2924 : integer, pointer :: ptr(:)
2925 :
2926 : integer :: i
2927 : logical :: okay
2928 :
2929 60 : if (.not. associated(ptr)) return
2930 :
2931 : if (work_array_debug) then
2932 : deallocate(ptr)
2933 : return
2934 : end if
2935 :
2936 30 : okay = .false.
2937 60 : !$omp critical (alloc_integer_work_array2)
2938 30 : num_returns = num_returns + 1
2939 60 : do i=1,num_int_work_arrays
2940 60 : if (return1(i)) then
2941 : okay = .true.
2942 : exit
2943 : end if
2944 : end do
2945 : !$omp end critical (alloc_integer_work_array2)
2946 30 : if (okay) return
2947 :
2948 0 : deallocate(ptr)
2949 0 : num_deallocs = num_deallocs + 1
2950 :
2951 : contains
2952 :
2953 60 : logical function return1(itry)
2954 : integer, intent(in) :: itry
2955 60 : if (associated(int_work_pointers(itry)% p)) then
2956 60 : return1 = .false.
2957 : return
2958 : end if
2959 30 : int_work_pointers(itry)% p => ptr
2960 30 : ptr => null()
2961 30 : return1 = .true.
2962 30 : end function return1
2963 :
2964 : end subroutine return_integer_work_array
2965 :
2966 :
2967 10 : subroutine get_logical_work_array(s, ptr, sz, extra, ierr)
2968 : type (star_info), pointer :: s
2969 : integer, intent(in) :: sz, extra
2970 : logical, pointer :: ptr(:)
2971 : integer, intent(out) :: ierr
2972 :
2973 : integer :: i
2974 : logical :: okay
2975 :
2976 10 : ierr = 0
2977 :
2978 : if (work_array_debug) then
2979 : allocate(ptr(sz + extra), stat=ierr)
2980 9 : return
2981 : end if
2982 :
2983 10 : okay = .false.
2984 20 : !$omp critical (alloc_logical_work_array1)
2985 10 : num_calls = num_calls + 1
2986 260 : do i=1,num_logical_work_arrays
2987 260 : if (get1(i)) then
2988 : okay = .true.
2989 : exit
2990 : end if
2991 : end do
2992 : !$omp end critical (alloc_logical_work_array1)
2993 10 : if (okay) return
2994 :
2995 1 : allocate(ptr(sz + extra), stat=ierr)
2996 1 : num_allocs = num_allocs + 1
2997 :
2998 : if (work_array_trace) &
2999 : write(*,*) 'allocate new logical work array'
3000 :
3001 : contains
3002 :
3003 259 : logical function get1(itry)
3004 : integer, intent(in) :: itry
3005 259 : logical, pointer :: p(:)
3006 : include 'formats'
3007 259 : if (.not. associated(logical_work_pointers(itry)% p)) then
3008 259 : get1 = .false.
3009 : return
3010 : end if
3011 9 : p => logical_work_pointers(itry)% p
3012 9 : logical_work_pointers(itry)% p => null()
3013 9 : if (size(p,dim=1) < sz) then
3014 : if (work_array_trace) &
3015 : write(*,3) 'enlarge logical work array', size(p,dim=1), sz + extra
3016 0 : deallocate(p)
3017 0 : allocate(p(sz + extra), stat=ierr)
3018 : end if
3019 9 : ptr => p
3020 9 : get1 = .true.
3021 259 : end function get1
3022 :
3023 : end subroutine get_logical_work_array
3024 :
3025 :
3026 10 : subroutine return_logical_work_array(s, ptr)
3027 : type (star_info), pointer :: s
3028 : logical, pointer :: ptr(:)
3029 :
3030 : integer :: i
3031 : logical :: okay
3032 :
3033 20 : if (.not. associated(ptr)) return
3034 :
3035 : if (work_array_debug) then
3036 : deallocate(ptr)
3037 : return
3038 : end if
3039 :
3040 10 : okay = .false.
3041 20 : !$omp critical (alloc_logical_work_array2)
3042 10 : num_returns = num_returns + 1
3043 10 : do i=1,num_logical_work_arrays
3044 10 : if (return1(i)) then
3045 : okay = .true.
3046 : exit
3047 : end if
3048 : end do
3049 : !$omp end critical (alloc_logical_work_array2)
3050 10 : if (okay) return
3051 :
3052 0 : deallocate(ptr)
3053 0 : num_deallocs = num_deallocs + 1
3054 :
3055 : contains
3056 :
3057 10 : logical function return1(itry)
3058 : integer, intent(in) :: itry
3059 10 : if (associated(logical_work_pointers(itry)% p)) then
3060 10 : return1 = .false.
3061 : return
3062 : end if
3063 10 : logical_work_pointers(itry)% p => ptr
3064 10 : ptr => null()
3065 10 : return1 = .true.
3066 10 : end function return1
3067 :
3068 : end subroutine return_logical_work_array
3069 :
3070 :
3071 1 : subroutine shutdown_alloc ()
3072 :
3073 1 : call free_work_arrays()
3074 :
3075 1 : end subroutine shutdown_alloc
3076 :
3077 :
3078 1 : subroutine free_work_arrays ()
3079 :
3080 : integer :: i
3081 :
3082 251 : do i=1,num_work_arrays
3083 251 : if (associated(work_pointers(i)%p)) then
3084 8 : deallocate(work_pointers(i)%p)
3085 : nullify(work_pointers(i)%p)
3086 8 : num_deallocs = num_deallocs + 1
3087 : end if
3088 : end do
3089 251 : do i=1,num_int_work_arrays
3090 251 : if (associated(int_work_pointers(i)%p)) then
3091 3 : deallocate(int_work_pointers(i)%p)
3092 : nullify(int_work_pointers(i)%p)
3093 3 : num_deallocs = num_deallocs + 1
3094 : end if
3095 : end do
3096 251 : do i=1,num_logical_work_arrays
3097 251 : if (associated(logical_work_pointers(i)%p)) then
3098 1 : deallocate(logical_work_pointers(i)%p)
3099 : nullify(logical_work_pointers(i)%p)
3100 1 : num_deallocs = num_deallocs + 1
3101 : end if
3102 : end do
3103 :
3104 1 : end subroutine free_work_arrays
3105 :
3106 0 : subroutine size_work_arrays
3107 : integer :: sz, num, i
3108 :
3109 : include 'formats'
3110 0 : sz = 0; num = 0
3111 0 : do i=1,num_work_arrays
3112 0 : sz = sz + get_size(i)
3113 : end do
3114 0 : do i=1,num_int_work_arrays
3115 0 : sz = sz + get_size_i(i)
3116 : end do
3117 0 : do i=1,num_logical_work_arrays
3118 0 : sz = sz + get_size_l(i)
3119 : end do
3120 :
3121 : write(*,'(a,5x,99i8)') &
3122 0 : 'work_arrays: num sz calls returns diff', &
3123 0 : num, sz, num_calls, num_returns, num_calls-num_returns, &
3124 0 : num_allocs, num_deallocs, num_allocs-num_deallocs
3125 0 : write(*,'(A)')
3126 :
3127 : contains
3128 :
3129 0 : integer function get_size(i)
3130 : integer, intent(in) :: i
3131 0 : if (associated(work_pointers(i)% p)) then
3132 0 : get_size = size(work_pointers(i)% p,dim=1)
3133 0 : num = num + 1
3134 : else
3135 : get_size = 0
3136 : end if
3137 0 : end function get_size
3138 :
3139 0 : integer function get_size_i(i)
3140 : integer, intent(in) :: i
3141 0 : if (associated(int_work_pointers(i)% p)) then
3142 0 : get_size_i = size(int_work_pointers(i)% p,dim=1)
3143 0 : num = num + 1
3144 : else
3145 : get_size_i = 0
3146 : end if
3147 0 : end function get_size_i
3148 :
3149 0 : integer function get_size_l(i)
3150 : integer, intent(in) :: i
3151 0 : if (associated(logical_work_pointers(i)% p)) then
3152 0 : get_size_l = size(logical_work_pointers(i)% p,dim=1)
3153 0 : num = num + 1
3154 : else
3155 : get_size_l = 0
3156 : end if
3157 0 : end function get_size_l
3158 :
3159 : end subroutine size_work_arrays
3160 :
3161 : ! Cleans array used by history.f90, cant think of better place?
3162 1 : subroutine dealloc_history(s)
3163 : use utils_lib, only: integer_dict_free
3164 : type(star_info), pointer :: s
3165 :
3166 1 : if (associated(s% history_values)) then
3167 1 : deallocate(s% history_values)
3168 1 : nullify(s% history_values)
3169 : end if
3170 1 : if (associated(s% history_names)) then
3171 1 : deallocate(s% history_names)
3172 1 : nullify(s% history_names)
3173 : end if
3174 1 : if (associated(s% history_value_is_integer)) then
3175 1 : deallocate(s% history_value_is_integer)
3176 1 : nullify(s% history_value_is_integer)
3177 : end if
3178 1 : if (associated(s% history_names_dict)) then
3179 1 : call integer_dict_free(s% history_names_dict)
3180 1 : nullify(s% history_names_dict)
3181 : end if
3182 :
3183 1 : end subroutine dealloc_history
3184 :
3185 :
3186 0 : subroutine get_work_array(s, ptr, sz, extra, str, ierr)
3187 : type (star_info), pointer :: s
3188 : integer, intent(in) :: sz, extra
3189 : real(dp), pointer :: ptr(:)
3190 : character (len=*), intent(in) :: str
3191 : integer, intent(out) :: ierr
3192 0 : call do_get_work_array(s, .true., ptr, sz, extra, str, ierr)
3193 0 : end subroutine get_work_array
3194 :
3195 :
3196 0 : subroutine return_work_array(s, ptr, str)
3197 : type (star_info), pointer :: s
3198 : real(dp), pointer :: ptr(:)
3199 : character (len=*), intent(in) :: str
3200 0 : call do_return_work_array(s, .true., ptr, str)
3201 0 : end subroutine return_work_array
3202 :
3203 :
3204 : ! okay to use this if sure don't need reentrant allocation
3205 0 : subroutine non_crit_return_work_array(s, ptr, str)
3206 : type (star_info), pointer :: s
3207 : real(dp), pointer :: ptr(:)
3208 : character (len=*), intent(in) :: str
3209 0 : call do_return_work_array(s, .false., ptr, str)
3210 0 : end subroutine non_crit_return_work_array
3211 :
3212 0 : end module alloc
|
