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