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 : 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 24 : call do1_logical(s% reconstructed_face_state_valid, c% reconstructed_face_state_valid)
1090 24 : if (failed('reconstructed_face_state_valid')) exit
1091 : ! cache entries are invalid until first use
1092 5352 : if (action == do_allocate) s% reconstructed_face_state_valid = .false.
1093 24 : call do1_ad(s% reconstructed_T_face_ad, c% reconstructed_T_face_ad)
1094 24 : if (failed('reconstructed_T_face_ad')) exit
1095 24 : call do1_ad(s% reconstructed_rho_face_ad, c% reconstructed_rho_face_ad)
1096 24 : if (failed('reconstructed_rho_face_ad')) exit
1097 24 : call do1_ad(s% reconstructed_P_face_ad, c% reconstructed_P_face_ad)
1098 24 : if (failed('reconstructed_P_face_ad')) exit
1099 24 : call do1_ad(s% reconstructed_energy_face_ad, c% reconstructed_energy_face_ad)
1100 24 : if (failed('reconstructed_energy_face_ad')) exit
1101 24 : call do1_ad(s% reconstructed_Cp_face_ad, c% reconstructed_Cp_face_ad)
1102 24 : if (failed('reconstructed_Cp_face_ad')) exit
1103 24 : call do1_ad(s% reconstructed_ChiRho_face_ad, c% reconstructed_ChiRho_face_ad)
1104 24 : if (failed('reconstructed_ChiRho_face_ad')) exit
1105 24 : call do1_ad(s% reconstructed_ChiT_face_ad, c% reconstructed_ChiT_face_ad)
1106 24 : if (failed('reconstructed_ChiT_face_ad')) exit
1107 24 : call do1_ad(s% reconstructed_grada_face_ad, c% reconstructed_grada_face_ad)
1108 24 : if (failed('reconstructed_grada_face_ad')) exit
1109 24 : call do1_ad(s% reconstructed_opacity_face_ad, c% reconstructed_opacity_face_ad)
1110 24 : if (failed('reconstructed_opacity_face_ad')) exit
1111 24 : call do1_ad(s% reconstructed_scale_height_face_ad, c% reconstructed_scale_height_face_ad)
1112 24 : if (failed('reconstructed_scale_height_face_ad')) exit
1113 24 : call do1_ad(s% reconstructed_gradr_face_ad, c% reconstructed_gradr_face_ad)
1114 24 : if (failed('reconstructed_gradr_face_ad')) exit
1115 24 : call do1(s% reconstructed_csound_face, c% reconstructed_csound_face)
1116 24 : if (failed('reconstructed_csound_face')) exit
1117 :
1118 24 : call do1_ad(s% PII_ad, c% PII_ad)
1119 24 : if (failed('PII_ad')) exit
1120 24 : call do1_ad(s% Chi_ad, c% Chi_ad)
1121 24 : if (failed('Chi_ad')) exit
1122 24 : call do1_ad(s% Eq_ad, c% Eq_ad)
1123 24 : if (failed('Eq_ad')) exit
1124 24 : call do1_ad(s% COUPL_ad, c% COUPL_ad)
1125 24 : if (failed('COUPL_ad')) exit
1126 24 : call do1_ad(s% Lr_ad, c% Lr_ad)
1127 24 : if (failed('Lr_ad')) exit
1128 24 : call do1_ad(s% Lc_ad, c% Lc_ad)
1129 24 : if (failed('Lc_ad')) exit
1130 24 : call do1_ad(s% Lt_ad, c% Lt_ad)
1131 24 : if (failed('Lt_ad')) exit
1132 :
1133 24 : call do1(s% gradT, c% gradT)
1134 24 : if (failed('gradT')) exit
1135 24 : call do1(s% gradr, c% gradr)
1136 24 : if (failed('gradr')) exit
1137 :
1138 24 : call do1(s% grad_density, c% grad_density)
1139 24 : if (failed('grad_density')) exit
1140 24 : call do1(s% grad_temperature, c% grad_temperature)
1141 24 : if (failed('grad_temperature')) exit
1142 24 : call do1(s% gradL, c% gradL)
1143 24 : if (failed('gradL')) exit
1144 24 : call do1(s% gradL_composition_term, c% gradL_composition_term)
1145 24 : if (failed('gradL_composition_term')) exit
1146 :
1147 : call do1_integer( &
1148 24 : s% dominant_iso_for_thermohaline, c% dominant_iso_for_thermohaline)
1149 24 : if (failed('dominant_iso_for_thermohaline')) exit
1150 :
1151 24 : call do1(s% sig, c% sig)
1152 24 : if (failed('sig')) exit
1153 24 : call do1(s% sig_raw, c% sig_raw)
1154 24 : if (failed('sig_raw')) exit
1155 :
1156 24 : call do1(s% brunt_N2, c% brunt_N2)
1157 24 : if (failed('brunt_N2')) exit
1158 24 : call do1(s% brunt_N2_composition_term, c% brunt_N2_composition_term)
1159 24 : if (failed('brunt_N2_composition_term')) exit
1160 24 : call do1(s% brunt_B, c% brunt_B)
1161 24 : if (failed('brunt_B')) exit
1162 24 : call do1(s% unsmoothed_brunt_B, c% unsmoothed_brunt_B)
1163 24 : if (failed('unsmoothed_brunt_B')) exit
1164 24 : call do1(s% smoothed_brunt_B, c% smoothed_brunt_B)
1165 24 : if (failed('smoothed_brunt_B')) exit
1166 :
1167 24 : call do1(s% RTI_du_diffusion_kick, c% RTI_du_diffusion_kick)
1168 24 : if (failed('RTI_du_diffusion_kick')) exit
1169 :
1170 24 : call do1_ad(s% u_face_ad, c% u_face_ad)
1171 24 : if (failed('u_face_ad')) exit
1172 24 : call do1(s% u_face_start, c% u_face_start)
1173 24 : if (failed('u_face_start')) exit
1174 24 : call do1(s% u_face_val, c% u_face_val)
1175 24 : if (failed('u_face_val')) exit
1176 24 : call do1(s% d_uface_domega, c% d_uface_domega)
1177 24 : if (failed('d_uface_domega')) exit
1178 :
1179 24 : call do1_ad(s% P_face_ad, c% P_face_ad)
1180 24 : if (failed('P_face_ad')) exit
1181 24 : call do1(s% P_face_start, c% P_face_start)
1182 24 : if (failed('P_face_start')) exit
1183 24 : call do1(s% abs_du_div_cs, c% abs_du_div_cs)
1184 24 : if (failed('abs_du_div_cs')) exit
1185 24 : call do1(s% abs_du_plus_cs, c% abs_du_plus_cs)
1186 24 : if (failed('abs_du_plus_cs')) exit
1187 :
1188 24 : call do1(s% dPdr_dRhodr_info, c% dPdr_dRhodr_info)
1189 24 : if (failed('dPdr_dRhodr_info')) exit
1190 24 : call do1(s% dPdr_info, c% dPdr_info)
1191 24 : if (failed('dPdr_info')) exit
1192 24 : call do1(s% dRhodr_info, c% dRhodr_info)
1193 24 : if (failed('dRhodr_info')) exit
1194 :
1195 24 : call do1(s% source_plus_alpha_RTI, c% source_plus_alpha_RTI)
1196 24 : if (failed('source_plus_alpha_RTI')) exit
1197 24 : call do1(s% source_minus_alpha_RTI, c% source_minus_alpha_RTI)
1198 24 : if (failed('source_minus_alpha_RTI')) exit
1199 24 : call do1(s% eta_RTI, c% eta_RTI)
1200 24 : if (failed('eta_RTI')) exit
1201 24 : call do1(s% etamid_RTI, c% etamid_RTI)
1202 24 : if (failed('etamid_RTI')) exit
1203 24 : call do1(s% boost_for_eta_RTI, c% boost_for_eta_RTI)
1204 24 : if (failed('boost_for_eta_RTI')) exit
1205 :
1206 24 : call do1(s% sig_RTI, c% sig_RTI)
1207 24 : if (failed('sig_RTI')) exit
1208 24 : call do1(s% sigmid_RTI, c% sigmid_RTI)
1209 24 : if (failed('sigmid_RTI')) exit
1210 :
1211 24 : call do1(s% L_nuc_burn, c% L_nuc_burn)
1212 24 : if (failed('L_nuc_burn')) exit
1213 :
1214 24 : call do2(s% xa_start, c% xa_start, species, 'xa_start')
1215 24 : if (failed('xa_start')) exit
1216 24 : call do2(s% xa_sub_xa_start, c% xa_sub_xa_start, species, 'xa_sub_xa_start')
1217 24 : if (failed('xa_sub_xa_start')) exit
1218 :
1219 24 : call do1(s% lnd_start, c% lnd_start)
1220 24 : if (failed('lnd_start')) exit
1221 24 : call do1(s% lnPgas_start, c% lnPgas_start)
1222 24 : if (failed('lnPgas_start')) exit
1223 24 : call do1(s% lnPeos_start, c% lnPeos_start)
1224 24 : if (failed('lnPeos_start')) exit
1225 24 : call do1(s% Peos_start, c% Peos_start)
1226 24 : if (failed('Peos_start')) exit
1227 24 : call do1(s% Peos_face_start, c% Peos_face_start)
1228 24 : if (failed('Peos_face_start')) exit
1229 24 : call do1(s% reconstructed_P_face_start, c% reconstructed_P_face_start)
1230 24 : if (failed('reconstructed_P_face_start')) exit
1231 24 : call do1(s% lnT_start, c% lnT_start)
1232 24 : if (failed('lnT_start')) exit
1233 24 : call do1(s% energy_start, c% energy_start)
1234 24 : if (failed('energy_start')) exit
1235 24 : call do1(s% egas_start, c% egas_start)
1236 24 : if (failed('egas_start')) exit
1237 24 : call do1(s% erad_start, c% erad_start)
1238 24 : if (failed('erad_start')) exit
1239 24 : call do1(s% Pgas_start, c% Pgas_start)
1240 24 : if (failed('Pgas_start')) exit
1241 24 : call do1(s% Prad_start, c% Prad_start)
1242 24 : if (failed('Prad_start')) exit
1243 24 : call do1(s% lnR_start, c% lnR_start)
1244 24 : if (failed('lnR_start')) exit
1245 24 : call do1(s% v_start, c% v_start)
1246 24 : if (failed('v_start')) exit
1247 24 : call do1(s% u_start, c% u_start)
1248 24 : if (failed('u_start')) exit
1249 24 : call do1(s% L_start, c% L_start)
1250 24 : if (failed('L_start')) exit
1251 24 : call do1(s% r_start, c% r_start)
1252 24 : if (failed('r_start')) exit
1253 24 : call do1(s% rmid_start, c% rmid_start)
1254 24 : if (failed('rmid_start')) exit
1255 24 : call do1(s% omega_start, c% omega_start)
1256 24 : if (failed('omega_start')) exit
1257 24 : call do1(s% ye_start, c% ye_start)
1258 24 : if (failed('ye_start')) exit
1259 24 : call do1(s% opacity_start, c% opacity_start)
1260 24 : if (failed('opacity_start')) exit
1261 24 : call do1(s% csound_start, c% csound_start)
1262 24 : if (failed('csound_start')) exit
1263 24 : call do1(s% alpha_RTI_start, c% alpha_RTI_start)
1264 24 : if (failed('alpha_RTI_start')) exit
1265 :
1266 24 : call do1(s% j_rot_start, c% j_rot_start)
1267 24 : if (failed('j_rot_start')) exit
1268 24 : call do1(s% i_rot_start, c% i_rot_start)
1269 24 : if (failed('i_rot_start')) exit
1270 24 : call do1(s% eps_nuc_start, c% eps_nuc_start)
1271 24 : if (failed('eps_nuc_start')) exit
1272 24 : call do1(s% non_nuc_neu_start, c% non_nuc_neu_start)
1273 24 : if (failed('non_nuc_neu_start')) exit
1274 24 : call do2(s% dxdt_nuc_start, c% dxdt_nuc_start, species, null_str)
1275 24 : if (failed('dxdt_nuc_start')) exit
1276 24 : call do1(s% grada_start, c% grada_start)
1277 24 : if (failed('grada_start')) exit
1278 24 : call do1(s% chiT_start, c% chiT_start)
1279 24 : if (failed('chiT_start')) exit
1280 24 : call do1(s% chiRho_start, c% chiRho_start)
1281 24 : if (failed('chiRho_start')) exit
1282 24 : call do1(s% cp_start, c% cp_start)
1283 24 : if (failed('cp_start')) exit
1284 24 : call do1(s% Cv_start, c% Cv_start)
1285 24 : if (failed('Cv_start')) exit
1286 24 : call do1(s% dE_dRho_start, c% dE_dRho_start)
1287 24 : if (failed('dE_dRho_start')) exit
1288 24 : call do1(s% gam_start, c% gam_start)
1289 24 : if (failed('gam_start')) exit
1290 24 : call do1(s% rho_start, c% rho_start)
1291 24 : if (failed('rho_start')) exit
1292 24 : call do1(s% lnS_start, c% lnS_start)
1293 24 : if (failed('lnS_start')) exit
1294 24 : call do1(s% T_start, c% T_start)
1295 24 : if (failed('T_start')) exit
1296 24 : call do1(s% zbar_start, c% zbar_start)
1297 24 : if (failed('zbar_start')) exit
1298 24 : call do1(s% mu_start, c% mu_start)
1299 24 : if (failed('mu_start')) exit
1300 :
1301 24 : call do1(s% phase_start, c% phase_start)
1302 24 : if (failed('phase_start')) exit
1303 24 : call do1(s% latent_ddlnT_start, c% latent_ddlnT_start)
1304 24 : if (failed('latent_ddlnT_start')) exit
1305 24 : call do1(s% latent_ddlnRho_start, c% latent_ddlnRho_start)
1306 24 : if (failed('latent_ddlnRho_start')) exit
1307 :
1308 24 : call do1(s% max_burn_correction, c% max_burn_correction)
1309 24 : if (failed('max_burn_correction')) exit
1310 24 : call do1(s% avg_burn_correction, c% avg_burn_correction)
1311 24 : if (failed('avg_burn_correction')) exit
1312 :
1313 24 : call do1(s% burn_avg_epsnuc, c% burn_avg_epsnuc)
1314 24 : if (failed('burn_avg_epsnuc')) exit
1315 24 : call do1_integer(s% burn_num_iters, c% burn_num_iters)
1316 24 : if (failed('burn_num_iters')) exit
1317 :
1318 24 : call do1_neq(s% residual_weight1, c% residual_weight1)
1319 24 : if (failed('residual_weight1')) exit
1320 24 : if (action == do_remove_from_center .or. action == do_reallocate .or. &
1321 : (action /= do_check_size .and. action /= do_deallocate)) &
1322 11 : s% residual_weight(1:nvar,1:nz) => s% residual_weight1(1:nvar*nz)
1323 :
1324 24 : call do1_neq(s% correction_weight1, c% correction_weight1)
1325 24 : if (failed('correction_weight1')) exit
1326 24 : if (action == do_remove_from_center .or. action == do_reallocate .or. &
1327 : (action /= do_check_size .and. action /= do_deallocate)) &
1328 11 : s% correction_weight(1:nvar,1:nz) => s% correction_weight1(1:nvar*nz)
1329 :
1330 24 : call do1_neq(s% solver_dx1, c% solver_dx1)
1331 24 : if (failed('solver_dx1')) exit
1332 24 : if (action == do_remove_from_center .or. action == do_reallocate .or. &
1333 : (action /= do_check_size .and. action /= do_deallocate)) &
1334 11 : s% solver_dx(1:nvar,1:nz) => s% solver_dx1(1:nvar*nz)
1335 :
1336 24 : call do1_neq(s% x_scale1, c% x_scale1)
1337 24 : if (failed('x_scale1')) exit
1338 24 : if (action == do_remove_from_center .or. action == do_reallocate .or. &
1339 : (action /= do_check_size .and. action /= do_deallocate)) &
1340 11 : s% x_scale(1:nvar,1:nz) => s% x_scale1(1:nvar*nz)
1341 :
1342 24 : call do1(s% eps_pre_mix, c% eps_pre_mix)
1343 24 : if (failed('eps_pre_mix')) exit
1344 :
1345 24 : call do1(s% max_abs_xa_corr, c% max_abs_xa_corr)
1346 24 : if (failed('max_abs_xa_corr')) exit
1347 :
1348 24 : call do1(s% Hp_face, c% Hp_face); if (failed('Hp_face')) exit
1349 :
1350 24 : call do1(s% Y_face, c% Y_face); if (failed('Y_face')) exit
1351 24 : call do1(s% Y_face_start, c% Y_face_start); if (failed('Y_face_start')) exit
1352 :
1353 24 : call do1(s% PII, c% PII); if (failed('PII')) exit
1354 :
1355 24 : call do1(s% Chi, c% Chi); if (failed('Chi')) exit
1356 24 : call do1(s% Chi_start, c% Chi_start); if (failed('Chi_start')) exit
1357 :
1358 24 : call do1(s% Lr, c% Lr); if (failed('Lr')) exit
1359 24 : call do1(s% Lc, c% Lc); if (failed('Lc')) exit
1360 24 : call do1(s% Lc_start, c% Lc_start); if (failed('Lc_start')) exit
1361 24 : call do1(s% Lt, c% Lt); if (failed('Lt')) exit
1362 24 : call do1(s% Lt_start, c% Lt_start); if (failed('Lt_start')) exit
1363 :
1364 24 : call do1(s% Fr, c% Fr); if (failed('Fr')) exit
1365 24 : call do1(s% Fr_start, c% Fr_start); if (failed('Fr_start')) exit
1366 24 : call do1(s% Pvsc, c% Pvsc); if (failed('Pvsc')) exit
1367 24 : call do1(s% Pvsc_start, c% Pvsc_start); if (failed('Pvsc_start')) exit
1368 24 : call do1(s% Ptrb, c% Ptrb); if (failed('Ptrb')) exit
1369 24 : call do1(s% Ptrb_start, c% Ptrb_start); if (failed('Ptrb_start')) exit
1370 24 : call do1(s% Eq, c% Eq); if (failed('Eq')) exit
1371 24 : call do1(s% SOURCE, c% SOURCE); if (failed('SOURCE')) exit
1372 24 : call do1(s% DAMP, c% DAMP); if (failed('DAMP')) exit
1373 24 : call do1(s% DAMPR, c% DAMPR); if (failed('DAMPR')) exit
1374 24 : call do1(s% COUPL, c% COUPL); if (failed('COUPL')) exit
1375 24 : call do1(s% COUPL_start, c% COUPL_start); if (failed('COUPL_start')) exit
1376 24 : call do1(s% RSP_w, c% RSP_w); if (failed('w')) exit
1377 24 : call do1(s% RSP_w_start, c% RSP_w_start); if (failed('w_start')) exit
1378 24 : call do1(s% Vol, c% Vol); if (failed('Vol')) exit
1379 24 : call do1(s% Vol_start, c% Vol_start); if (failed('Vol_start')) exit
1380 24 : call do1(s% Uq, c% Uq); if (failed('Uq')) exit
1381 24 : call do1(s% f_Edd, c% f_Edd); if (failed('f_Edd')) exit
1382 :
1383 24 : call do1(s% xtra1_array, c% xtra1_array)
1384 24 : if (failed('xtra1_array')) exit
1385 24 : call do1(s% xtra2_array, c% xtra2_array)
1386 24 : if (failed('xtra2_array')) exit
1387 24 : call do1(s% xtra3_array, c% xtra3_array)
1388 24 : if (failed('xtra3_array')) exit
1389 24 : call do1(s% xtra4_array, c% xtra4_array)
1390 24 : if (failed('xtra4_array')) exit
1391 24 : call do1(s% xtra5_array, c% xtra5_array)
1392 24 : if (failed('xtra5_array')) exit
1393 24 : call do1(s% xtra6_array, c% xtra6_array)
1394 24 : if (failed('xtra6_array')) exit
1395 :
1396 24 : call do1_integer(s% ixtra1_array, c% ixtra1_array)
1397 24 : if (failed('ixtra1_array')) exit
1398 24 : call do1_integer(s% ixtra2_array, c% ixtra2_array)
1399 24 : if (failed('ixtra2_array')) exit
1400 24 : call do1_integer(s% ixtra3_array, c% ixtra3_array)
1401 24 : if (failed('ixtra3_array')) exit
1402 24 : call do1_integer(s% ixtra4_array, c% ixtra4_array)
1403 24 : if (failed('ixtra4_array')) exit
1404 24 : call do1_integer(s% ixtra5_array, c% ixtra5_array)
1405 24 : if (failed('ixtra5_array')) exit
1406 24 : call do1_integer(s% ixtra6_array, c% ixtra6_array)
1407 24 : if (failed('ixtra6_array')) exit
1408 :
1409 24 : if (action_in /= do_check_size) then
1410 13 : if (action_in /= do_copy_pointers_and_resize .and. &
1411 : action_in /= do_reallocate) then
1412 3 : call do2D_dim1(s, s% profile_extra, nz, max_num_profile_extras, action, ierr)
1413 : else
1414 10 : deallocate(s% profile_extra)
1415 30 : allocate(s% profile_extra(nz, max_num_profile_extras), stat=ierr)
1416 : end if
1417 13 : if (failed('pstar extras')) exit
1418 : end if
1419 :
1420 24 : call do2(s% prev_mesh_xh, c% prev_mesh_xh, nvar_hydro, 'prev_mesh_xh')
1421 24 : if (failed('prev_mesh_xh')) exit
1422 24 : call do2(s% prev_mesh_xa, c% prev_mesh_xa, species, 'prev_mesh_xa')
1423 24 : if (failed('prev_mesh_xa')) exit
1424 24 : call do1(s% prev_mesh_j_rot, c% prev_mesh_j_rot)
1425 24 : if (failed('prev_mesh_j_rot')) exit
1426 24 : call do1(s% prev_mesh_omega, c% prev_mesh_omega)
1427 24 : if (failed('prev_mesh_omega')) exit
1428 24 : call do1(s% prev_mesh_mlt_vc, c% prev_mesh_mlt_vc)
1429 24 : if (failed('prev_mesh_mlt_vc')) exit
1430 24 : call do1(s% prev_mesh_dq, c% prev_mesh_dq)
1431 24 : if (failed('prev_mesh_dq')) exit
1432 : ! These are needed for time-smoothing of ST mixing
1433 24 : call do1(s% prev_mesh_D_ST_start, c% prev_mesh_D_ST_start)
1434 24 : if (failed('prev_mesh_D_ST_start')) exit
1435 24 : call do1(s% prev_mesh_nu_ST_start, c% prev_mesh_nu_ST_start)
1436 24 : if (failed('prev_mesh_nu_ST_start')) exit
1437 :
1438 24 : if (s% fill_arrays_with_NaNs) s% need_to_setvars = .true.
1439 24 : return
1440 : end do
1441 0 : ierr = -1
1442 :
1443 :
1444 : contains
1445 :
1446 :
1447 912 : subroutine do1_ad(ptr, other)
1448 : type(auto_diff_real_star_order1), dimension(:), pointer :: ptr, other
1449 912 : if (action == do_fill_arrays_with_NaNs) then
1450 0 : call fill_ad_with_NaNs(ptr,1,-1)
1451 912 : else if (action == do_copy_pointers_and_resize) then
1452 342 : ptr => other
1453 342 : if (nz <= size(ptr,dim=1)) then
1454 342 : if (s% fill_arrays_with_NaNs) call fill_ad_with_NaNs(ptr,1,-1)
1455 342 : return
1456 : end if
1457 0 : deallocate(ptr)
1458 0 : allocate(ptr(sz_new), stat=ierr)
1459 0 : if (s% fill_arrays_with_NaNs) call fill_ad_with_NaNs(ptr,1,-1)
1460 0 : if (s% zero_when_allocate) call fill_ad_with_zeros(ptr,1,-1)
1461 : else
1462 570 : if (action == do_reallocate) then
1463 0 : if (nz <= size(ptr,dim=1)) return
1464 : end if
1465 570 : call do1D_ad(s, ptr, sz_new, action, ierr)
1466 570 : if (action == do_allocate) then
1467 76 : if (s% fill_arrays_with_NaNs) call fill_ad_with_NaNs(ptr,1,-1)
1468 76 : if (s% zero_when_allocate) call fill_ad_with_zeros(ptr,1,-1)
1469 : end if
1470 : end if
1471 : end subroutine do1_ad
1472 :
1473 :
1474 7584 : subroutine do1(ptr, other)
1475 : real(dp), dimension(:), pointer :: ptr, other
1476 7584 : if (action == do_fill_arrays_with_NaNs) then
1477 0 : call fill_with_NaNs(ptr)
1478 7584 : else if (action == do_copy_pointers_and_resize) then
1479 2844 : ptr => other
1480 2844 : if (.not. associated(ptr)) then
1481 0 : call mesa_error(__FILE__,__LINE__,'do1 ptr not associated')
1482 : end if
1483 2844 : if (nz <= size(ptr,dim=1)) then
1484 2844 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1485 2844 : return
1486 : end if
1487 0 : deallocate(ptr)
1488 0 : allocate(ptr(sz_new), stat=ierr)
1489 0 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1490 0 : if (s% zero_when_allocate) ptr(:) = 0
1491 : else
1492 4740 : if (action == do_reallocate) then
1493 0 : if (nz <= size(ptr,dim=1)) return
1494 : end if
1495 4740 : call do1D(s, ptr, sz_new, action, ierr)
1496 4740 : if (action == do_allocate) then
1497 632 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1498 632 : if (s% zero_when_allocate) ptr(:) = 0
1499 : end if
1500 : end if
1501 : end subroutine do1
1502 :
1503 :
1504 96 : subroutine do1_neq(ptr, other)
1505 : real(dp), dimension(:), pointer :: ptr, other
1506 96 : if (action == do_fill_arrays_with_NaNs) then
1507 0 : call fill_with_NaNs(ptr)
1508 96 : else if (action == do_copy_pointers_and_resize) then
1509 36 : ptr => other
1510 36 : if (nvar*nz <= size(ptr,dim=1)) then
1511 36 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1512 36 : if (s% zero_when_allocate) ptr(:) = 0
1513 36 : return
1514 : end if
1515 0 : deallocate(ptr)
1516 0 : allocate(ptr(nvar*sz_new), stat=ierr)
1517 0 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1518 0 : if (s% zero_when_allocate) ptr(:) = 0
1519 : else
1520 60 : if (action == do_reallocate) then
1521 0 : if (nvar*nz <= size(ptr,dim=1)) return
1522 : end if
1523 60 : call do1D(s, ptr, nvar*sz_new, action, ierr)
1524 60 : if (action == do_allocate) then
1525 8 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs(ptr)
1526 8 : if (s% zero_when_allocate) ptr(:) = 0
1527 : end if
1528 : end if
1529 : end subroutine do1_neq
1530 :
1531 :
1532 264 : subroutine do1_integer(ptr, other)
1533 : integer, dimension(:), pointer :: ptr, other
1534 264 : if (action == do_copy_pointers_and_resize) then
1535 99 : ptr => other
1536 99 : if (nz <= size(ptr,dim=1)) return
1537 0 : deallocate(ptr)
1538 0 : allocate(ptr(sz_new), stat=ierr)
1539 : else
1540 165 : if (action == do_reallocate) then
1541 0 : if (nz <= size(ptr,dim=1)) return
1542 : end if
1543 165 : call do1D_integer(s, ptr, sz_new, action, ierr)
1544 : end if
1545 : end subroutine do1_integer
1546 :
1547 :
1548 : subroutine do2_integer(ptr, other, sz1)
1549 : integer, dimension(:,:), pointer :: ptr, other
1550 : integer, intent(in) :: sz1
1551 : if (action == do_copy_pointers_and_resize) then
1552 : ptr => other
1553 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) return
1554 : deallocate(ptr)
1555 : allocate(ptr(sz1, sz_new), stat=ierr)
1556 : else
1557 : if (action == do_reallocate) then
1558 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) return
1559 : end if
1560 : call do2D_integer(s, ptr, sz1, sz_new, action, ierr)
1561 : end if
1562 : end subroutine do2_integer
1563 :
1564 :
1565 72 : subroutine do1_logical(ptr, other)
1566 : logical, dimension(:), pointer :: ptr, other
1567 72 : if (action == do_copy_pointers_and_resize) then
1568 27 : ptr => other
1569 27 : if (nz <= size(ptr,dim=1)) return
1570 0 : deallocate(ptr)
1571 0 : allocate(ptr(sz_new), stat=ierr)
1572 : else
1573 45 : if (action == do_reallocate) then
1574 0 : if (nz <= size(ptr,dim=1)) return
1575 : end if
1576 45 : call do1D_logical(s, ptr, sz_new, action, ierr)
1577 : end if
1578 : end subroutine do1_logical
1579 :
1580 :
1581 748 : subroutine do2(ptr, other, sz1, str)
1582 : real(dp), dimension(:,:), pointer :: ptr, other
1583 : integer, intent(in) :: sz1
1584 : character (len=*), intent(in) :: str
1585 : include 'formats'
1586 748 : if (action == do_fill_arrays_with_NaNs) then
1587 0 : call fill_with_NaNs_2d(ptr)
1588 748 : else if (action == do_copy_pointers_and_resize) then
1589 297 : ptr => other
1590 297 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) then
1591 297 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_2d(ptr)
1592 297 : if (s% zero_when_allocate) ptr(:,:) = 0
1593 297 : return
1594 : end if
1595 0 : deallocate(ptr)
1596 0 : allocate(ptr(sz1, sz_new), stat=ierr)
1597 0 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_2d(ptr)
1598 0 : if (s% zero_when_allocate) ptr(:,:) = 0
1599 : else
1600 451 : if (action == do_reallocate) then
1601 0 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) return
1602 : end if
1603 451 : call do2D(s, ptr, sz1, sz_new, action, ierr)
1604 451 : if (action == do_allocate) then
1605 66 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_2d(ptr)
1606 66 : if (s% zero_when_allocate) ptr(:,:) = 0
1607 : end if
1608 : end if
1609 : end subroutine do2
1610 :
1611 :
1612 48 : subroutine do3(ptr, other, sz1, sz2)
1613 : real(dp), dimension(:,:,:), pointer :: ptr, other
1614 : integer, intent(in) :: sz1, sz2
1615 48 : if (action == do_fill_arrays_with_NaNs) then
1616 0 : call fill_with_NaNs_3d(ptr)
1617 48 : elseif (action == do_copy_pointers_and_resize) then
1618 18 : ptr => other
1619 : if (sz1 == size(ptr, dim=1) .and. sz2 == size(ptr, dim=2) &
1620 18 : .and. nz <= size(ptr, dim=3)) then
1621 18 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_3d(ptr)
1622 18 : if (s% zero_when_allocate) ptr(:,:,:) = 0
1623 18 : return
1624 : end if
1625 0 : deallocate(ptr)
1626 0 : allocate(ptr(sz1, sz2, sz_new), stat=ierr)
1627 0 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_3d(ptr)
1628 0 : if (s% zero_when_allocate) ptr(:,:,:) = 0
1629 : else
1630 30 : if (action == do_reallocate) then
1631 : if (sz1 == size(ptr, dim=1) .and. &
1632 0 : sz2 == size(ptr, dim=2) .and. &
1633 : nz <= size(ptr, dim=3)) return
1634 : end if
1635 30 : call do3D(s, ptr, sz1, sz2, sz_new, action, ierr)
1636 30 : if (action == do_allocate) then
1637 4 : if (s% fill_arrays_with_NaNs) call fill_with_NaNs_3d(ptr)
1638 4 : if (s% zero_when_allocate) ptr(:,:,:) = 0
1639 : end if
1640 : end if
1641 : end subroutine do3
1642 :
1643 :
1644 : subroutine do2_quad(ptr, other, sz1)
1645 : real(qp), dimension(:,:), pointer :: ptr, other
1646 : integer, intent(in) :: sz1
1647 : if (action == do_copy_pointers_and_resize) then
1648 : ptr => other
1649 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) return
1650 : deallocate(ptr)
1651 : allocate(ptr(sz1, sz_new), stat=ierr)
1652 : else
1653 : if (action == do_reallocate) then
1654 : if (sz1 == size(ptr, dim=1) .and. nz <= size(ptr, dim=2)) return
1655 : end if
1656 : call do2D_quad(s, ptr, sz1, sz_new, action, ierr)
1657 : end if
1658 : end subroutine do2_quad
1659 :
1660 :
1661 9737 : logical function failed(str)
1662 : character (len=*), intent(in) :: str
1663 : include 'formats'
1664 9737 : failed = .false.
1665 9737 : if (ierr == 0) return
1666 0 : write(*,*) 'star_info_arrays failed for ' // trim(str)
1667 0 : write(*,2) 'action', action
1668 0 : write(*,2) 'species', species
1669 0 : write(*,2) 'nz', nz
1670 0 : failed = .true.
1671 0 : end function failed
1672 :
1673 :
1674 : end subroutine star_info_arrays
1675 :
1676 :
1677 0 : subroutine fill_ad_with_NaNs(ptr, klo, khi_in)
1678 : type(auto_diff_real_star_order1), dimension(:), pointer :: ptr
1679 : integer, intent(in) :: klo, khi_in
1680 : integer :: k, khi
1681 0 : if (khi_in == -1) then
1682 0 : khi = size(ptr,dim=1)
1683 : else
1684 : khi = khi_in
1685 : end if
1686 0 : do k=klo,khi
1687 0 : call set_nan(ptr(k)% val)
1688 0 : call fill_with_NaNs(ptr(k)% d1Array)
1689 : end do
1690 0 : end subroutine fill_ad_with_NaNs
1691 :
1692 :
1693 1 : subroutine fill_ad_with_zeros(ptr, klo, khi_in)
1694 : type(auto_diff_real_star_order1), dimension(:), pointer :: ptr
1695 : integer, intent(in) :: klo, khi_in
1696 : integer :: k, khi
1697 1 : if (khi_in == -1) then
1698 1 : khi = size(ptr,dim=1)
1699 : else
1700 : khi = khi_in
1701 : end if
1702 2665 : do k=klo,khi
1703 2664 : ptr(k)% val = 0d0
1704 90577 : ptr(k)% d1Array(:) = 0d0
1705 : end do
1706 1 : end subroutine fill_ad_with_zeros
1707 :
1708 :
1709 570 : subroutine do1D_ad(s, ptr, sz, action, ierr)
1710 : type (star_info), pointer :: s
1711 : type(auto_diff_real_star_order1), dimension(:), pointer :: ptr
1712 : integer, intent(in) :: sz, action
1713 : integer, intent(out) :: ierr
1714 570 : type(auto_diff_real_star_order1), dimension(:), pointer :: ptr2
1715 : integer :: old_sz, j
1716 : include 'formats'
1717 570 : ierr = 0
1718 646 : select case(action)
1719 : case (do_deallocate)
1720 76 : if (associated(ptr)) then
1721 76 : deallocate(ptr)
1722 : nullify(ptr)
1723 : end if
1724 : case (do_allocate)
1725 228 : allocate(ptr(sz), stat=ierr)
1726 76 : if (s% fill_arrays_with_NaNs) then
1727 0 : call fill_ad_with_NaNs(ptr,1,-1)
1728 76 : else if (s% zero_when_allocate) then
1729 0 : call fill_ad_with_zeros(ptr,1,-1)
1730 : end if
1731 : case (do_check_size)
1732 418 : if (size(ptr,dim=1) < sz) ierr = -1
1733 : case (do_remove_from_center)
1734 0 : allocate(ptr2(sz), stat=ierr)
1735 0 : old_sz = size(ptr,dim=1)
1736 0 : do j=1,min(old_sz,sz)
1737 0 : ptr2(j) = ptr(j)
1738 : end do
1739 0 : deallocate(ptr)
1740 0 : if (ierr /= 0) return
1741 0 : ptr => ptr2
1742 : case (do_reallocate)
1743 0 : if (associated(ptr)) then
1744 0 : if (size(ptr,dim=1) >= sz) return
1745 : else
1746 0 : ierr = -1
1747 0 : return
1748 : end if
1749 0 : allocate(ptr2(sz), stat=ierr)
1750 0 : old_sz = size(ptr,dim=1)
1751 0 : do j=1,old_sz
1752 0 : ptr2(j) = ptr(j)
1753 : end do
1754 0 : if (s% fill_arrays_with_NaNs) then
1755 0 : call fill_ad_with_NaNs(ptr2,old_sz+1,sz)
1756 0 : else if (s% zero_when_allocate) then
1757 0 : call fill_ad_with_zeros(ptr2,old_sz+1,sz)
1758 : end if
1759 0 : deallocate(ptr)
1760 0 : if (ierr /= 0) return
1761 0 : ptr => ptr2
1762 : case (do_fill_arrays_with_NaNs)
1763 0 : if (associated(ptr)) call fill_ad_with_NaNs(ptr,1,-1)
1764 : end select
1765 570 : end subroutine do1D_ad
1766 :
1767 :
1768 4860 : subroutine do1D(s, ptr, sz, action, ierr)
1769 : type (star_info), pointer :: s
1770 : real(dp), dimension(:), pointer :: ptr
1771 : integer, intent(in) :: sz, action
1772 : integer, intent(out) :: ierr
1773 4860 : real(dp), dimension(:), pointer :: ptr2
1774 : integer :: old_sz, j
1775 : include 'formats'
1776 4860 : ierr = 0
1777 5505 : select case(action)
1778 : case (do_deallocate)
1779 645 : if (associated(ptr)) then
1780 645 : deallocate(ptr)
1781 : nullify(ptr)
1782 : end if
1783 : case (do_allocate)
1784 1920 : allocate(ptr(sz), stat=ierr)
1785 640 : if (s% fill_arrays_with_NaNs) then
1786 0 : call set_nan(ptr)
1787 640 : else if (s% zero_when_allocate) then
1788 0 : ptr(1:sz) = 0
1789 : end if
1790 : case (do_check_size)
1791 3575 : if (size(ptr,dim=1) < sz) ierr = -1
1792 : case (do_remove_from_center)
1793 0 : allocate(ptr2(sz), stat=ierr)
1794 0 : old_sz = size(ptr,dim=1)
1795 0 : do j=1,min(old_sz,sz)
1796 0 : ptr2(j) = ptr(j)
1797 : end do
1798 0 : deallocate(ptr)
1799 0 : if (ierr /= 0) return
1800 0 : ptr => ptr2
1801 : case (do_reallocate)
1802 0 : if (associated(ptr)) then
1803 0 : if (size(ptr,dim=1) >= sz) return
1804 : else
1805 0 : ierr = -1
1806 0 : return
1807 : end if
1808 0 : allocate(ptr2(sz), stat=ierr)
1809 0 : old_sz = size(ptr,dim=1)
1810 0 : do j=1,old_sz
1811 0 : ptr2(j) = ptr(j)
1812 : end do
1813 0 : if (s% fill_arrays_with_NaNs) then
1814 0 : do j=old_sz+1,sz
1815 0 : call set_nan(ptr2(j))
1816 : end do
1817 0 : else if (s% zero_when_allocate) then
1818 0 : do j=old_sz+1,sz
1819 0 : ptr2(j) = 0
1820 : end do
1821 : end if
1822 0 : deallocate(ptr)
1823 0 : if (ierr /= 0) return
1824 0 : ptr => ptr2
1825 : case (do_fill_arrays_with_NaNs)
1826 0 : if (associated(ptr)) call set_nan(ptr)
1827 : end select
1828 4860 : end subroutine do1D
1829 :
1830 :
1831 475 : subroutine do2D(s, ptr, sz1, sz2, action, ierr)
1832 :
1833 : type (star_info), pointer :: s
1834 : real(dp), dimension(:,:), pointer:: ptr
1835 : integer, intent(in) :: sz1, sz2, action
1836 : integer, intent(out) :: ierr
1837 475 : real(dp), dimension(:,:), pointer :: ptr2
1838 : integer :: old_sz2, j, i
1839 475 : ierr = 0
1840 543 : select case(action)
1841 : case (do_deallocate)
1842 68 : if (associated(ptr)) then
1843 68 : deallocate(ptr)
1844 : nullify(ptr)
1845 : end if
1846 : case (do_allocate)
1847 264 : allocate(ptr(sz1, sz2), stat=ierr)
1848 66 : if (s% fill_arrays_with_NaNs) then
1849 0 : call set_nan(ptr)
1850 66 : else if (s% zero_when_allocate) then
1851 0 : ptr(1:sz1,1:sz2) = 0
1852 : end if
1853 : case (do_check_size)
1854 341 : if (size(ptr,dim=1) /= sz1) ierr = -1
1855 341 : if (size(ptr,dim=2) < sz2) ierr = -1
1856 : case (do_remove_from_center)
1857 0 : allocate(ptr2(sz1, sz2), stat=ierr)
1858 0 : old_sz2 = size(ptr,dim=2)
1859 0 : do j=1,min(old_sz2,sz2)
1860 0 : do i=1,sz1
1861 0 : ptr2(i,j) = ptr(i,j)
1862 : end do
1863 : end do
1864 0 : deallocate(ptr)
1865 0 : if (ierr /= 0) return
1866 0 : ptr => ptr2
1867 : case (do_reallocate)
1868 0 : if (associated(ptr)) then
1869 0 : if (size(ptr,dim=1) /= sz1) then
1870 0 : ierr = -1
1871 0 : return
1872 : end if
1873 0 : if (size(ptr,dim=2) >= sz2) return
1874 : else
1875 0 : ierr = -1
1876 0 : return
1877 : end if
1878 0 : allocate(ptr2(sz1, sz2), stat=ierr)
1879 0 : old_sz2 = size(ptr,dim=2)
1880 0 : do j=1,old_sz2
1881 0 : do i=1,sz1
1882 0 : ptr2(i,j) = ptr(i,j)
1883 : end do
1884 : end do
1885 0 : if (s% fill_arrays_with_NaNs) then
1886 0 : do j=old_sz2+1,sz2
1887 0 : do i=1,sz1
1888 0 : call set_nan(ptr2(i,j))
1889 : end do
1890 : end do
1891 0 : else if (s% zero_when_allocate) then
1892 0 : do j=old_sz2+1,sz2
1893 0 : do i=1,sz1
1894 0 : ptr2(i,j) = 0
1895 : end do
1896 : end do
1897 : end if
1898 0 : deallocate(ptr)
1899 0 : if (ierr /= 0) return
1900 0 : ptr => ptr2
1901 : case (do_fill_arrays_with_NaNs)
1902 0 : if (associated(ptr)) call set_nan(ptr)
1903 : end select
1904 475 : end subroutine do2D
1905 :
1906 :
1907 0 : subroutine do2D_quad(s, ptr, sz1, sz2, action, ierr)
1908 : type (star_info), pointer :: s
1909 : real(qp), dimension(:,:), pointer:: ptr
1910 : integer, intent(in) :: sz1, sz2, action
1911 : integer, intent(out) :: ierr
1912 0 : real(qp), dimension(:,:), pointer :: ptr2
1913 : integer :: old_sz2, j, i
1914 0 : ierr = 0
1915 0 : select case(action)
1916 : case (do_deallocate)
1917 0 : if (associated(ptr)) then
1918 0 : deallocate(ptr)
1919 : nullify(ptr)
1920 : end if
1921 : case (do_allocate)
1922 0 : allocate(ptr(sz1, sz2), stat=ierr)
1923 0 : if (s% zero_when_allocate) ptr = 0
1924 : case (do_check_size)
1925 0 : if (size(ptr,dim=1) /= sz1) ierr = -1
1926 0 : if (size(ptr,dim=2) < sz2) ierr = -1
1927 : case (do_remove_from_center)
1928 0 : allocate(ptr2(sz1, sz2), stat=ierr)
1929 0 : old_sz2 = size(ptr,dim=2)
1930 0 : do i=1,sz1
1931 0 : do j=1,min(old_sz2,sz2)
1932 0 : ptr2(i,j) = ptr(i,j)
1933 : end do
1934 : end do
1935 0 : deallocate(ptr)
1936 0 : if (ierr /= 0) return
1937 0 : ptr => ptr2
1938 : case (do_reallocate)
1939 0 : if (associated(ptr)) then
1940 0 : if (size(ptr,dim=1) /= sz1) then
1941 0 : ierr = -1
1942 0 : return
1943 : end if
1944 0 : if (size(ptr,dim=2) >= sz2) return
1945 : else
1946 0 : ierr = -1
1947 0 : return
1948 : end if
1949 0 : allocate(ptr2(sz1, sz2), stat=ierr)
1950 0 : old_sz2 = size(ptr,dim=2)
1951 0 : do j=1,old_sz2
1952 0 : do i=1,sz1
1953 0 : ptr2(i,j) = ptr(i,j)
1954 : end do
1955 : end do
1956 0 : deallocate(ptr)
1957 0 : if (ierr /= 0) return
1958 0 : ptr => ptr2
1959 : end select
1960 0 : end subroutine do2D_quad
1961 :
1962 :
1963 3 : subroutine do2D_dim1(s, ptr, sz1, sz2, action, ierr)
1964 :
1965 : type (star_info), pointer :: s
1966 : real(dp), dimension(:,:), pointer:: ptr
1967 : integer, intent(in) :: sz1, sz2, action
1968 : integer, intent(out) :: ierr
1969 3 : real(dp), dimension(:,:), pointer :: ptr2
1970 : integer :: old_sz1, j,i
1971 3 : ierr = 0
1972 5 : select case(action)
1973 : case (do_deallocate)
1974 2 : if (associated(ptr)) then
1975 1 : deallocate(ptr)
1976 : nullify(ptr)
1977 : end if
1978 : case (do_allocate)
1979 4 : allocate(ptr(sz1, sz2), stat=ierr)
1980 1 : if (s% fill_arrays_with_NaNs) then
1981 0 : call set_nan(ptr)
1982 1 : else if (s% zero_when_allocate) then
1983 0 : ptr(1:sz1,1:sz2) = 0
1984 : end if
1985 : case (do_remove_from_center)
1986 0 : allocate(ptr2(sz1, sz2), stat=ierr)
1987 0 : old_sz1 = size(ptr,dim=1)
1988 0 : do j=1,sz2
1989 0 : do i=1,min(old_sz1,sz1)
1990 0 : ptr2(i,j) = ptr(i,j)
1991 : end do
1992 : end do
1993 0 : deallocate(ptr)
1994 0 : if (ierr /= 0) return
1995 0 : ptr => ptr2
1996 : end select
1997 3 : end subroutine do2D_dim1
1998 :
1999 :
2000 30 : subroutine do3D(s, ptr, sz1, sz2, sz3, action, ierr)
2001 :
2002 : type (star_info), pointer :: s
2003 : real(dp), dimension(:,:,:), pointer:: ptr
2004 : integer, intent(in) :: sz1, sz2, sz3, action
2005 : integer, intent(out) :: ierr
2006 30 : real(dp), dimension(:,:,:), pointer :: ptr2
2007 : integer :: old_sz3, j, i, k
2008 30 : ierr = 0
2009 34 : select case(action)
2010 : case (do_deallocate)
2011 4 : if (associated(ptr)) then
2012 4 : deallocate(ptr)
2013 : nullify(ptr)
2014 : end if
2015 : case (do_allocate)
2016 20 : allocate(ptr(sz1, sz2, sz3), stat=ierr)
2017 4 : if (s% fill_arrays_with_NaNs) then
2018 0 : call set_nan(ptr)
2019 4 : else if (s% zero_when_allocate) then
2020 0 : ptr(1:sz1,1:sz2,1:sz3) = 0
2021 : end if
2022 : case (do_check_size)
2023 22 : if (size(ptr,dim=1) /= sz1) ierr = -1
2024 22 : if (size(ptr,dim=2) /= sz2) ierr = -1
2025 22 : if (size(ptr,dim=3) < sz3) ierr = -1
2026 : case (do_remove_from_center)
2027 0 : allocate(ptr2(sz1, sz2, sz3), stat=ierr)
2028 0 : old_sz3 = size(ptr,dim=3)
2029 0 : do k=1,min(old_sz3,sz3)
2030 0 : do j=1,sz2
2031 0 : do i=1,sz1
2032 0 : ptr2(i,j,k) = ptr(i,j,k)
2033 : end do
2034 : end do
2035 : end do
2036 0 : deallocate(ptr)
2037 0 : if (ierr /= 0) return
2038 0 : ptr => ptr2
2039 : case (do_reallocate)
2040 0 : if (associated(ptr)) then
2041 0 : if (size(ptr,dim=1) /= sz1 .or. size(ptr,dim=2) /= sz2) then
2042 0 : ierr = -1
2043 0 : return
2044 : end if
2045 0 : if (size(ptr,dim=3) >= sz3) return
2046 : else
2047 0 : ierr = -1
2048 0 : return
2049 : end if
2050 0 : allocate(ptr2(sz1, sz2, sz3), stat=ierr)
2051 0 : old_sz3 = size(ptr,dim=3)
2052 0 : do k=1,old_sz3
2053 0 : do j=1,sz2
2054 0 : do i=1,sz1
2055 0 : ptr2(i,j,k) = ptr(i,j,k)
2056 : end do
2057 : end do
2058 : end do
2059 0 : if (s% fill_arrays_with_NaNs) then
2060 0 : do k=old_sz3+1,sz3
2061 0 : do j=1,sz2
2062 0 : do i=1,sz1
2063 0 : call set_nan(ptr2(i,j,k))
2064 : end do
2065 : end do
2066 : end do
2067 0 : else if (s% zero_when_allocate) then
2068 0 : do k=old_sz3+1,sz3
2069 0 : do j=1,sz2
2070 0 : do i=1,sz1
2071 0 : ptr2(i,j,k) = 0
2072 : end do
2073 : end do
2074 : end do
2075 : end if
2076 0 : deallocate(ptr)
2077 0 : if (ierr /= 0) return
2078 0 : ptr => ptr2
2079 : case (do_fill_arrays_with_NaNs)
2080 0 : if (associated(ptr)) call set_nan(ptr)
2081 : end select
2082 30 : end subroutine do3D
2083 :
2084 :
2085 0 : subroutine do4D(s, ptr, sz1, sz2, sz3, sz4, action, ierr)
2086 :
2087 : type (star_info), pointer :: s
2088 : real(dp), dimension(:,:,:,:), pointer:: ptr
2089 : integer, intent(in) :: sz1, sz2, sz3, sz4, action
2090 : integer, intent(out) :: ierr
2091 0 : real(dp), dimension(:,:,:,:), pointer :: ptr2
2092 : integer :: old_sz4, i, j, k, m
2093 0 : ierr = 0
2094 0 : select case(action)
2095 : case (do_deallocate)
2096 0 : if (associated(ptr)) then
2097 0 : deallocate(ptr)
2098 : nullify(ptr)
2099 : end if
2100 : case (do_allocate)
2101 0 : allocate(ptr(sz1, sz2, sz3, sz4), stat=ierr)
2102 0 : if (s% fill_arrays_with_NaNs) then
2103 0 : call set_nan(ptr)
2104 0 : else if (s% zero_when_allocate) then
2105 0 : ptr(1:sz1,1:sz2,1:sz3,1:sz4) = 0
2106 : end if
2107 : case (do_check_size)
2108 0 : if (size(ptr,dim=1) /= sz1) ierr = -1
2109 0 : if (size(ptr,dim=2) /= sz2) ierr = -1
2110 0 : if (size(ptr,dim=3) /= sz3) ierr = -1
2111 0 : if (size(ptr,dim=4) < sz4) ierr = -1
2112 : case (do_remove_from_center)
2113 0 : allocate(ptr2(sz1, sz2, sz3, sz4), stat=ierr)
2114 0 : old_sz4 = size(ptr,dim=4)
2115 0 : do m=1,min(old_sz4,sz4)
2116 0 : do k=1,sz3
2117 0 : do j=1,sz2
2118 0 : do i=1,sz1
2119 0 : ptr2(i,j,k,m) = ptr(i,j,k,m)
2120 : end do
2121 : end do
2122 : end do
2123 : end do
2124 0 : deallocate(ptr)
2125 0 : if (ierr /= 0) return
2126 0 : ptr => ptr2
2127 : case (do_reallocate)
2128 0 : if (associated(ptr)) then
2129 : if (size(ptr,dim=1) /= sz1 .or. &
2130 0 : size(ptr,dim=2) /= sz2 .or. &
2131 : size(ptr,dim=3) /= sz3) then
2132 0 : ierr = -1
2133 0 : return
2134 : end if
2135 0 : if (size(ptr,dim=4) >= sz4) return
2136 : else
2137 0 : ierr = -1
2138 0 : return
2139 : end if
2140 0 : allocate(ptr2(sz1, sz2, sz3, sz4), stat=ierr)
2141 0 : old_sz4 = size(ptr,dim=4)
2142 0 : do m=1,old_sz4
2143 0 : do k=1,sz3
2144 0 : do j=1,sz2
2145 0 : do i=1,sz1
2146 0 : ptr2(i,j,k,m) = ptr(i,j,k,m)
2147 : end do
2148 : end do
2149 : end do
2150 : end do
2151 0 : if (s% fill_arrays_with_NaNs) then
2152 0 : do m=old_sz4+1,sz4
2153 0 : do k=1,sz3
2154 0 : do j=1,sz2
2155 0 : do i=1,sz1
2156 0 : call set_nan(ptr2(i,j,k,m))
2157 : end do
2158 : end do
2159 : end do
2160 : end do
2161 0 : else if (s% zero_when_allocate) then
2162 0 : do m=old_sz4+1,sz4
2163 0 : do k=1,sz3
2164 0 : do j=1,sz2
2165 0 : do i=1,sz1
2166 0 : ptr2(i,j,k,m) = 0
2167 : end do
2168 : end do
2169 : end do
2170 : end do
2171 : end if
2172 0 : deallocate(ptr)
2173 0 : if (ierr /= 0) return
2174 0 : ptr => ptr2
2175 : case (do_fill_arrays_with_NaNs)
2176 0 : call set_nan(ptr)
2177 : end select
2178 0 : end subroutine do4D
2179 :
2180 :
2181 165 : subroutine do1D_integer(s, ptr, sz, action, ierr)
2182 : type (star_info), pointer :: s
2183 : integer, dimension(:), pointer:: ptr
2184 : integer, intent(in) :: sz, action
2185 : integer, intent(out) :: ierr
2186 165 : integer, dimension(:), pointer :: ptr2
2187 : integer :: old_sz, j
2188 165 : ierr = 0
2189 187 : select case(action)
2190 : case (do_deallocate)
2191 22 : if (associated(ptr)) then
2192 22 : deallocate(ptr)
2193 : nullify(ptr)
2194 : end if
2195 : case (do_allocate)
2196 66 : allocate(ptr(sz), stat=ierr)
2197 22 : if (s% zero_when_allocate) ptr = 0
2198 : case (do_check_size)
2199 121 : if (size(ptr,dim=1) < sz) ierr = -1
2200 : case (do_remove_from_center)
2201 0 : allocate(ptr2(sz), stat=ierr)
2202 0 : old_sz = size(ptr,dim=1)
2203 0 : do j=1,min(old_sz,sz)
2204 0 : ptr2(j) = ptr(j)
2205 : end do
2206 0 : deallocate(ptr)
2207 0 : if (ierr /= 0) return
2208 0 : ptr => ptr2
2209 : case (do_reallocate)
2210 0 : if (associated(ptr)) then
2211 0 : if (size(ptr,dim=1) >= sz) return
2212 : else
2213 0 : ierr = -1
2214 0 : return
2215 : end if
2216 0 : allocate(ptr2(sz), stat=ierr)
2217 0 : old_sz = size(ptr,dim=1)
2218 0 : do j=1,old_sz
2219 0 : ptr2(j) = ptr(j)
2220 : end do
2221 0 : deallocate(ptr)
2222 0 : if (ierr /= 0) return
2223 0 : ptr => ptr2
2224 : end select
2225 165 : end subroutine do1D_integer
2226 :
2227 :
2228 0 : subroutine do2D_integer(s, ptr, sz1, sz2, action, ierr)
2229 : type (star_info), pointer :: s
2230 : integer, dimension(:, :), pointer:: ptr
2231 : integer, intent(in) :: sz1, sz2, action
2232 : integer, intent(out) :: ierr
2233 0 : integer, dimension(:,:), pointer :: ptr2
2234 : integer :: old_sz2, j, i
2235 0 : ierr = 0
2236 0 : select case(action)
2237 : case (do_deallocate)
2238 0 : if (associated(ptr)) then
2239 0 : deallocate(ptr)
2240 : nullify(ptr)
2241 : end if
2242 : case (do_allocate)
2243 0 : allocate(ptr(sz1, sz2), stat=ierr)
2244 0 : if (s% zero_when_allocate) ptr = 0
2245 : case (do_check_size)
2246 0 : if (size(ptr,dim=1) /= sz1) ierr = -1
2247 0 : if (size(ptr,dim=2) < sz2) ierr = -1
2248 : case (do_remove_from_center)
2249 0 : allocate(ptr2(sz1, sz2), stat=ierr)
2250 0 : old_sz2 = size(ptr,dim=2)
2251 0 : do j=1,min(old_sz2,sz2)
2252 0 : do i=1,sz1
2253 0 : ptr2(i,j) = ptr(i,j)
2254 : end do
2255 : end do
2256 0 : deallocate(ptr)
2257 0 : if (ierr /= 0) return
2258 0 : ptr => ptr2
2259 : case (do_reallocate)
2260 0 : if (associated(ptr)) then
2261 0 : if (size(ptr,dim=1) /= sz1) then
2262 0 : ierr = -1
2263 0 : return
2264 : end if
2265 0 : if (size(ptr,dim=2) >= sz2) return
2266 : else
2267 0 : ierr = -1
2268 0 : return
2269 : end if
2270 0 : allocate(ptr2(sz1, sz2), stat=ierr)
2271 0 : old_sz2 = size(ptr,dim=2)
2272 0 : do j=1,old_sz2
2273 0 : do i=1,sz1
2274 0 : ptr2(i,j) = ptr(i,j)
2275 : end do
2276 : end do
2277 0 : deallocate(ptr)
2278 0 : if (ierr /= 0) return
2279 0 : ptr => ptr2
2280 : end select
2281 0 : end subroutine do2D_integer
2282 :
2283 :
2284 45 : subroutine do1D_logical(s, ptr, sz, action, ierr)
2285 : type (star_info), pointer :: s
2286 : logical, dimension(:), pointer:: ptr
2287 : integer, intent(in) :: sz, action
2288 : integer, intent(out) :: ierr
2289 45 : logical, dimension(:), pointer :: ptr2
2290 : integer :: old_sz, j
2291 45 : ierr = 0
2292 51 : select case(action)
2293 : case (do_deallocate)
2294 6 : if (associated(ptr)) then
2295 6 : deallocate(ptr)
2296 : nullify(ptr)
2297 : end if
2298 : case (do_allocate)
2299 18 : allocate(ptr(sz), stat=ierr)
2300 6 : if (s% zero_when_allocate) ptr = .false.
2301 : case (do_check_size)
2302 33 : if (size(ptr,dim=1) < sz) ierr = -1
2303 : case (do_remove_from_center)
2304 0 : allocate(ptr2(sz), stat=ierr)
2305 0 : old_sz = size(ptr,dim=1)
2306 0 : do j=1,min(old_sz,sz)
2307 0 : ptr2(j) = ptr(j)
2308 : end do
2309 0 : deallocate(ptr)
2310 0 : if (ierr /= 0) return
2311 0 : ptr => ptr2
2312 : case (do_reallocate)
2313 0 : if (associated(ptr)) then
2314 0 : if (size(ptr,dim=1) >= sz) return
2315 : else
2316 0 : ierr = -1
2317 0 : return
2318 : end if
2319 0 : allocate(ptr2(sz), stat=ierr)
2320 0 : old_sz = size(ptr,dim=1)
2321 0 : do j=1,old_sz
2322 0 : ptr2(j) = ptr(j)
2323 : end do
2324 0 : deallocate(ptr)
2325 0 : if (ierr /= 0) return
2326 0 : ptr => ptr2
2327 : end select
2328 45 : end subroutine do1D_logical
2329 :
2330 :
2331 1 : subroutine set_var_info(s, ierr)
2332 : type (star_info), pointer :: s
2333 : integer, intent(out) :: ierr
2334 :
2335 : integer :: i
2336 :
2337 : include 'formats'
2338 :
2339 1 : ierr = 0
2340 : i = 0
2341 :
2342 : ! first assign variable numbers
2343 1 : i = i+1; s% i_lnd = i
2344 1 : i = i+1; s% i_lnT = i
2345 1 : i = i+1; s% i_lnR = i
2346 :
2347 1 : if (.not. s% RSP_flag) then
2348 1 : i = i+1; s% i_lum = i
2349 : else
2350 0 : s% i_lum = 0
2351 : end if
2352 :
2353 1 : if (s% v_flag) then
2354 0 : i = i+1; s% i_v = i
2355 : else
2356 1 : s% i_v = 0
2357 : end if
2358 :
2359 1 : if (s% u_flag) then
2360 0 : i = i+1;s% i_u = i
2361 : else
2362 1 : s% i_u = 0
2363 : end if
2364 :
2365 1 : if (s% RTI_flag) then
2366 0 : i = i+1; s% i_alpha_RTI = i
2367 : else
2368 1 : s% i_alpha_RTI = 0
2369 : end if
2370 :
2371 1 : if (s% RSP_flag) then
2372 0 : i = i+1; s% i_Et_RSP = i
2373 0 : i = i+1; s% i_erad_RSP = i
2374 0 : i = i+1; s% i_Fr_RSP = i
2375 : else
2376 1 : s% i_Et_RSP = 0
2377 1 : s% i_erad_RSP = 0
2378 1 : s% i_Fr_RSP = 0
2379 : end if
2380 :
2381 1 : if (s% RSP2_flag) then
2382 0 : i = i+1; s% i_w = i
2383 0 : i = i+1; s% i_Hp = i
2384 : else
2385 1 : s% i_w = 0
2386 1 : s% i_Hp = 0
2387 : end if
2388 :
2389 1 : if (s% w_div_wc_flag) then
2390 0 : i = i+1; s% i_w_div_wc = i
2391 : else
2392 1 : s% i_w_div_wc = 0
2393 : end if
2394 :
2395 1 : if (s% j_rot_flag) then
2396 0 : i = i+1; s% i_j_rot = i
2397 : else
2398 1 : s% i_j_rot = 0
2399 : end if
2400 :
2401 : ! now assign equation numbers
2402 1 : if (s% i_v /= 0 .or. s% i_u /= 0) then
2403 0 : s% i_dlnd_dt = s% i_lnd
2404 0 : s% i_dlnE_dt = s% i_lnT
2405 0 : s% i_equL = s% i_lum
2406 0 : s% i_dlnR_dt = s% i_lnR
2407 0 : s% i_dv_dt = s% i_v
2408 0 : s% i_du_dt = s% i_u
2409 : else ! HSE is included in dv_dt, so drop dlnR_dt
2410 1 : s% i_equL = s% i_lnd
2411 1 : s% i_dv_dt = s% i_lnT
2412 1 : s% i_dlnE_dt = s% i_lum
2413 1 : s% i_dlnd_dt = s% i_lnR
2414 1 : s% i_dlnR_dt = 0
2415 1 : s% i_du_dt = 0
2416 : end if
2417 :
2418 1 : s% i_detrb_dt = s% i_w
2419 1 : s% i_equ_Hp = s% i_Hp
2420 1 : s% i_dalpha_RTI_dt = s% i_alpha_RTI
2421 1 : s% i_dEt_RSP_dt = s% i_Et_RSP
2422 1 : s% i_derad_RSP_dt = s% i_erad_RSP
2423 1 : s% i_dFr_RSP_dt = s% i_Fr_RSP
2424 1 : s% i_equ_w_div_wc = s% i_w_div_wc
2425 1 : s% i_dj_rot_dt = s% i_j_rot
2426 :
2427 1 : s% nvar_hydro = i
2428 1 : s% nvar_total = s% nvar_hydro + s% nvar_chem
2429 :
2430 : ! Names of the variables
2431 1 : if (s% i_lnd /= 0) s% nameofvar(s% i_lnd) = 'lnd'
2432 1 : if (s% i_lnT /= 0) s% nameofvar(s% i_lnT) = 'lnT'
2433 1 : if (s% i_lnR /= 0) s% nameofvar(s% i_lnR) = 'lnR'
2434 1 : if (s% i_lum /= 0) s% nameofvar(s% i_lum) = 'L'
2435 1 : if (s% i_v /= 0) s% nameofvar(s% i_v) = 'v'
2436 1 : if (s% i_w /= 0) s% nameofvar(s% i_w) = 'w'
2437 1 : if (s% i_Hp/= 0) s% nameofvar(s% i_Hp) = 'Hp'
2438 1 : if (s% i_alpha_RTI /= 0) s% nameofvar(s% i_alpha_RTI) = 'alpha_RTI'
2439 1 : if (s% i_Et_RSP /= 0) s% nameofvar(s% i_Et_RSP) = 'etrb_RSP'
2440 1 : if (s% i_erad_RSP /= 0) s% nameofvar(s% i_erad_RSP) = 'erad_RSP'
2441 1 : if (s% i_Fr_RSP /= 0) s% nameofvar(s% i_Fr_RSP) = 'Fr_RSP'
2442 1 : if (s% i_w_div_wc /= 0) s% nameofvar(s% i_w_div_wc) = 'w_div_wc'
2443 1 : if (s% i_j_rot /= 0) s% nameofvar(s% i_j_rot) = 'j_rot'
2444 1 : if (s% i_u /= 0) s% nameofvar(s% i_u) = 'u'
2445 :
2446 : ! Names of the equations
2447 1 : if (s% i_dv_dt /= 0) s% nameofequ(s% i_dv_dt) = 'dv_dt'
2448 1 : if (s% i_equL /= 0) s% nameofequ(s% i_equL) = 'equL'
2449 1 : if (s% i_dlnd_dt /= 0) s% nameofequ(s% i_dlnd_dt) = 'dlnd_dt'
2450 1 : if (s% i_dlnE_dt /= 0) s% nameofequ(s% i_dlnE_dt) = 'dlnE_dt'
2451 1 : if (s% i_dlnR_dt /= 0) s% nameofequ(s% i_dlnR_dt) = 'dlnR_dt'
2452 1 : if (s% i_detrb_dt /= 0) s% nameofequ(s% i_detrb_dt) = 'detrb_dt'
2453 1 : if (s% i_equ_Hp /= 0) s% nameofequ(s% i_equ_Hp) = 'equ_Hp'
2454 1 : if (s% i_dalpha_RTI_dt /= 0) s% nameofequ(s% i_dalpha_RTI_dt) = 'dalpha_RTI_dt'
2455 1 : if (s% i_dEt_RSP_dt /= 0) s% nameofequ(s% i_dEt_RSP_dt) = 'dEt_RSP_dt'
2456 1 : if (s% i_derad_RSP_dt /= 0) s% nameofequ(s% i_derad_RSP_dt) = 'derad_RSP_dt'
2457 1 : if (s% i_dFr_RSP_dt /= 0) s% nameofequ(s% i_dFr_RSP_dt) = 'dFr_RSP_dt'
2458 1 : if (s% i_equ_w_div_wc /= 0) s% nameofequ(s% i_equ_w_div_wc) = 'equ_w_div_wc'
2459 1 : if (s% i_dj_rot_dt /= 0) s% nameofequ(s% i_dj_rot_dt) = 'dj_rot_dt'
2460 1 : if (s% i_du_dt /= 0) s% nameofequ(s% i_du_dt) = 'du_dt'
2461 :
2462 : ! chem names are done later by set_chem_names when have set up the net
2463 :
2464 :
2465 1 : s% need_to_setvars = .true.
2466 :
2467 1 : end subroutine set_var_info
2468 :
2469 :
2470 1 : subroutine set_chem_names(s)
2471 : use chem_def
2472 : type (star_info), pointer :: s
2473 : integer :: old_size, i, j, cid
2474 :
2475 : include 'formats'
2476 :
2477 1 : if (s% nvar_hydro == 0) return ! not ready to set chem names yet
2478 :
2479 1 : old_size = size(s% nameofvar,dim=1)
2480 1 : if (old_size < s% nvar_total) then
2481 0 : call realloc(s% nameofvar)
2482 0 : call realloc(s% nameofequ)
2483 : end if
2484 9 : do i=1, s% nvar_chem
2485 8 : cid = s% chem_id(i)
2486 8 : j = s% nvar_hydro+i
2487 8 : s% nameofvar(j) = trim(chem_isos% name(cid))
2488 9 : s% nameofequ(j) = 'equ_' // trim(chem_isos% name(cid))
2489 : end do
2490 :
2491 : contains
2492 :
2493 0 : subroutine realloc(p)
2494 : character (len=name_len), dimension(:), pointer :: p
2495 0 : character (len=name_len), dimension(:), pointer :: old_p
2496 : integer :: cpy_len, j
2497 0 : old_p => p
2498 0 : old_size = size(p,dim=1)
2499 0 : allocate(p(s% nvar_total))
2500 0 : cpy_len = min(old_size, s% nvar_total)
2501 0 : do j=1,cpy_len
2502 0 : p(j) = old_p(j)
2503 : end do
2504 0 : deallocate(old_p)
2505 0 : end subroutine realloc
2506 :
2507 : subroutine realloc_logical(p)
2508 : logical, dimension(:), pointer :: p
2509 : logical, dimension(:), pointer :: old_p
2510 : integer :: cpy_len, j
2511 : old_p => p
2512 : old_size = size(p,dim=1)
2513 : allocate(p(s% nvar_total))
2514 : cpy_len = min(old_size, s% nvar_total)
2515 : do j=1,cpy_len
2516 : p(j) = old_p(j)
2517 : end do
2518 : deallocate(old_p)
2519 : end subroutine realloc_logical
2520 :
2521 : end subroutine set_chem_names
2522 :
2523 :
2524 0 : subroutine realloc_work_array(s, crit, ptr, oldsz, newsz, extra, str, ierr)
2525 : type (star_info), pointer :: s
2526 : logical, intent(in) :: crit
2527 : integer, intent(in) :: oldsz, newsz, extra
2528 : real(dp), pointer :: ptr(:)
2529 : character (len=*), intent(in) :: str
2530 : integer, intent(out) :: ierr
2531 : real(dp), pointer :: tmp(:)
2532 : integer :: k
2533 0 : tmp => ptr
2534 0 : call work_array(s, .true., crit, ptr, newsz, extra, str, ierr)
2535 0 : if (ierr /= 0) return
2536 0 : do k=1,min(oldsz,newsz)
2537 0 : ptr(k) = tmp(k)
2538 : end do
2539 0 : call work_array(s, .false., crit, tmp, newsz, extra, str, ierr)
2540 : end subroutine realloc_work_array
2541 :
2542 : ! if alloc is false, then deallocate ptr
2543 : ! if crit is false, then don't need reentrant allocation
2544 424 : subroutine work_array(s, alloc, crit, ptr, sz, extra, str, ierr)
2545 : type (star_info), pointer :: s
2546 : logical, intent(in) :: alloc, crit
2547 : integer, intent(in) :: sz, extra
2548 : real(dp), pointer :: ptr(:)
2549 : character (len=*), intent(in) :: str
2550 : integer, intent(out) :: ierr
2551 424 : ierr = 0
2552 424 : if (alloc) then
2553 212 : call do_get_work_array(s, crit, ptr, sz, extra, str, ierr)
2554 : else
2555 212 : call do_return_work_array(s, crit, ptr, str)
2556 : end if
2557 424 : end subroutine work_array
2558 :
2559 :
2560 212 : subroutine do_get_work_array(s, crit, ptr, sz, extra, str, ierr)
2561 : type (star_info), pointer :: s
2562 : logical, intent(in) :: crit
2563 : integer, intent(in) :: sz, extra
2564 : real(dp), pointer :: ptr(:)
2565 : character (len=*), intent(in) :: str
2566 : integer, intent(out) :: ierr
2567 :
2568 : integer :: i
2569 : logical :: okay
2570 :
2571 212 : ierr = 0
2572 :
2573 : if (work_array_debug) then
2574 : allocate(ptr(sz + extra), stat=ierr)
2575 : if (s% fill_arrays_with_NaNs) call set_nan(ptr)
2576 204 : return
2577 : end if
2578 :
2579 212 : okay = .false.
2580 :
2581 212 : if (crit) then
2582 0 : !$omp critical (alloc_work_array1)
2583 0 : num_calls = num_calls + 1 ! not safe, but just for info
2584 0 : do i = 1, num_work_arrays
2585 0 : if (get1(i)) then
2586 : okay = .true.
2587 : exit
2588 : end if
2589 : end do
2590 : !$omp end critical (alloc_work_array1)
2591 : else
2592 212 : num_calls = num_calls + 1
2593 2596 : do i = 1, num_work_arrays
2594 2596 : if (get1(i)) then
2595 : okay = .true.
2596 : exit
2597 : end if
2598 : end do
2599 : end if
2600 212 : if (okay) return
2601 :
2602 24 : allocate(ptr(sz + extra), stat=ierr)
2603 8 : num_allocs = num_allocs + 1
2604 8 : if (s% fill_arrays_with_NaNs) then
2605 0 : call set_nan(ptr)
2606 8 : else if (s% zero_when_allocate) then
2607 0 : ptr(:) = 0
2608 : end if
2609 :
2610 : if (work_array_trace) write(*,*) 'allocate new work array'
2611 :
2612 : contains
2613 :
2614 2588 : logical function get1(itry)
2615 : integer, intent(in) :: itry
2616 2588 : real(dp), pointer :: p(:)
2617 : include 'formats'
2618 2588 : if (.not. associated(work_pointers(itry)% p)) then
2619 2588 : get1 = .false.
2620 : return
2621 : end if
2622 204 : p => work_pointers(itry)% p
2623 204 : work_pointers(itry)% p => null()
2624 204 : if (size(p,dim=1) < sz) then
2625 : if (work_array_trace) &
2626 : write(*,4) 'enlarge work array ' // trim(str), &
2627 : itry, size(p,dim=1), sz + extra
2628 6 : deallocate(p)
2629 18 : allocate(p(sz + extra), stat=ierr)
2630 : else
2631 : if (work_array_trace) &
2632 : write(*,4) 'use work array ' // trim(str), itry, size(p,dim=1)
2633 : end if
2634 204 : ptr => p
2635 204 : get1 = .true.
2636 204 : if (s% fill_arrays_with_NaNs) then
2637 0 : call set_nan(ptr)
2638 204 : else if (s% zero_when_allocate) then
2639 0 : ptr(:) = 0
2640 : end if
2641 2588 : end function get1
2642 :
2643 : end subroutine do_get_work_array
2644 :
2645 :
2646 212 : subroutine do_return_work_array(s, crit, ptr, str)
2647 : type (star_info), pointer :: s
2648 : logical, intent(in) :: crit
2649 : real(dp), pointer :: ptr(:)
2650 : character (len=*), intent(in) :: str
2651 :
2652 : integer :: i
2653 : logical :: okay
2654 :
2655 212 : if (.not. associated(ptr)) then
2656 : !write(*,*) 'bogus call on do_return_work_array with nil ptr ' // trim(str)
2657 : !call mesa_error(__FILE__,__LINE__,'do_return_work_array')
2658 212 : return
2659 : end if
2660 :
2661 : if (work_array_debug) then
2662 : deallocate(ptr)
2663 : return
2664 : end if
2665 :
2666 212 : okay = .false.
2667 212 : if (crit) then
2668 0 : !$omp critical (alloc_work_array2)
2669 0 : num_returns = num_returns + 1
2670 0 : do i=1,num_work_arrays
2671 0 : if (return1(i)) then
2672 : okay = .true.
2673 : exit
2674 : end if
2675 : end do
2676 : !$omp end critical (alloc_work_array2)
2677 : else
2678 212 : num_returns = num_returns + 1
2679 624 : do i=1,num_work_arrays
2680 624 : if (return1(i)) then
2681 : okay = .true.
2682 : exit
2683 : end if
2684 : end do
2685 : end if
2686 212 : if (okay) return
2687 :
2688 0 : deallocate(ptr)
2689 0 : num_deallocs = num_deallocs + 1
2690 :
2691 : contains
2692 :
2693 624 : logical function return1(itry)
2694 : integer, intent(in) :: itry
2695 : include 'formats'
2696 624 : if (associated(work_pointers(itry)% p)) then
2697 624 : return1 = .false.
2698 : return
2699 : end if
2700 : if (work_array_trace) &
2701 : write(*,3) 'return work array ' // trim(str), itry, size(ptr,dim=1)
2702 212 : work_pointers(itry)% p => ptr
2703 212 : ptr => null()
2704 212 : return1 = .true.
2705 212 : end function return1
2706 :
2707 : end subroutine do_return_work_array
2708 :
2709 :
2710 0 : subroutine get_quad_array(s, ptr, sz, extra, str, ierr)
2711 : type (star_info), pointer :: s
2712 : integer, intent(in) :: sz, extra
2713 : real(qp), pointer :: ptr(:)
2714 : character (len=*), intent(in) :: str
2715 : integer, intent(out) :: ierr
2716 0 : call do_get_quad_array(s, .true., ptr, sz, extra, str, ierr)
2717 0 : end subroutine get_quad_array
2718 :
2719 :
2720 : ! okay to use this if sure don't need reentrant allocation
2721 0 : subroutine non_crit_get_quad_array(s, ptr, sz, extra, str, ierr)
2722 : type (star_info), pointer :: s
2723 : integer, intent(in) :: sz, extra
2724 : real(qp), pointer :: ptr(:)
2725 : character (len=*), intent(in) :: str
2726 : integer, intent(out) :: ierr
2727 0 : call do_get_quad_array(s, .false., ptr, sz, extra, str, ierr)
2728 0 : end subroutine non_crit_get_quad_array
2729 :
2730 :
2731 0 : subroutine do_get_quad_array(s, crit, ptr, sz, extra, str, ierr)
2732 : type (star_info), pointer :: s
2733 : logical, intent(in) :: crit
2734 : integer, intent(in) :: sz, extra
2735 : real(qp), pointer :: ptr(:)
2736 : character (len=*), intent(in) :: str
2737 : integer, intent(out) :: ierr
2738 :
2739 : integer :: i
2740 : logical :: okay
2741 :
2742 0 : ierr = 0
2743 :
2744 : if (quad_array_debug) then
2745 : allocate(ptr(sz + extra), stat=ierr)
2746 0 : return
2747 : end if
2748 :
2749 0 : okay = .false.
2750 0 : if (crit) then
2751 0 : !$omp critical (alloc_quad_work_array1)
2752 0 : num_calls = num_calls + 1
2753 0 : do i = 1, num_quad_arrays
2754 0 : if (get1(i)) then
2755 : okay = .true.
2756 : exit
2757 : end if
2758 : end do
2759 : !$omp end critical (alloc_quad_work_array1)
2760 : else
2761 0 : num_calls = num_calls + 1
2762 0 : do i = 1, num_quad_arrays
2763 0 : if (get1(i)) then
2764 : okay = .true.
2765 : exit
2766 : end if
2767 : end do
2768 : end if
2769 0 : if (okay) return
2770 :
2771 0 : allocate(ptr(sz + extra), stat=ierr)
2772 0 : num_allocs = num_allocs + 1
2773 :
2774 : if (quad_array_trace) write(*,*) 'allocate new quad array'
2775 :
2776 : contains
2777 :
2778 0 : logical function get1(itry)
2779 : integer, intent(in) :: itry
2780 0 : real(qp), pointer :: p(:)
2781 : include 'formats'
2782 0 : if (.not. associated(quad_pointers(itry)% p)) then
2783 0 : get1 = .false.
2784 : return
2785 : end if
2786 0 : p => quad_pointers(itry)% p
2787 0 : quad_pointers(itry)% p => null()
2788 0 : if (size(p,dim=1) < sz) then
2789 : if (quad_array_trace) &
2790 : write(*,4) 'enlarge quad array ' // trim(str), itry, size(p,dim=1), sz + extra
2791 0 : deallocate(p)
2792 0 : allocate(p(sz + extra), stat=ierr)
2793 : else
2794 : if (quad_array_trace) &
2795 : write(*,4) 'use quad array ' // trim(str), itry, size(p,dim=1)
2796 : end if
2797 0 : ptr => p
2798 0 : get1 = .true.
2799 0 : end function get1
2800 :
2801 : end subroutine do_get_quad_array
2802 :
2803 :
2804 0 : subroutine return_quad_array(s, ptr, str)
2805 : type (star_info), pointer :: s
2806 : real(qp), pointer :: ptr(:)
2807 : character (len=*), intent(in) :: str
2808 0 : call do_return_quad_array(s, .true., ptr, str)
2809 0 : end subroutine return_quad_array
2810 :
2811 :
2812 : ! okay to use this if sure don't need reentrant allocation
2813 0 : subroutine non_crit_return_quad_array(s, ptr, str)
2814 : type (star_info), pointer :: s
2815 : real(qp), pointer :: ptr(:)
2816 : character (len=*), intent(in) :: str
2817 0 : if (.not. associated(ptr)) return
2818 0 : call do_return_quad_array(s, .false., ptr, str)
2819 : end subroutine non_crit_return_quad_array
2820 :
2821 :
2822 0 : subroutine do_return_quad_array(s, crit, ptr, str)
2823 : type (star_info), pointer :: s
2824 : logical, intent(in) :: crit
2825 : real(qp), pointer :: ptr(:)
2826 : character (len=*), intent(in) :: str
2827 :
2828 : integer :: i
2829 : logical :: okay
2830 :
2831 0 : if (.not. associated(ptr)) return
2832 :
2833 : if (quad_array_debug) then
2834 : deallocate(ptr)
2835 : return
2836 : end if
2837 :
2838 0 : okay = .false.
2839 0 : if (crit) then
2840 0 : !$omp critical (alloc_quad_work_array2)
2841 0 : num_returns = num_returns + 1
2842 0 : do i=1,num_quad_arrays
2843 0 : if (return1(i)) then
2844 : okay = .true.
2845 : exit
2846 : end if
2847 : end do
2848 : !$omp end critical (alloc_quad_work_array2)
2849 : else
2850 0 : num_returns = num_returns + 1
2851 0 : do i=1,num_quad_arrays
2852 0 : if (return1(i)) then
2853 : okay = .true.
2854 : exit
2855 : end if
2856 : end do
2857 : end if
2858 0 : if (okay) return
2859 :
2860 0 : deallocate(ptr)
2861 0 : num_deallocs = num_deallocs + 1
2862 :
2863 : contains
2864 :
2865 0 : logical function return1(itry)
2866 : integer, intent(in) :: itry
2867 : include 'formats'
2868 0 : if (associated(quad_pointers(itry)% p)) then
2869 0 : return1 = .false.
2870 : return
2871 : end if
2872 : if (quad_array_trace) &
2873 : write(*,3) 'return quad array ' // trim(str), itry, size(ptr,dim=1)
2874 0 : quad_pointers(itry)% p => ptr
2875 0 : ptr => null()
2876 0 : return1 = .true.
2877 0 : end function return1
2878 :
2879 : end subroutine do_return_quad_array
2880 :
2881 :
2882 0 : subroutine realloc_integer_work_array(s, ptr, oldsz, newsz, extra, ierr)
2883 : type (star_info), pointer :: s
2884 : integer, intent(in) :: oldsz, newsz, extra
2885 : integer, pointer :: ptr(:)
2886 : integer, intent(out) :: ierr
2887 : integer, pointer :: itmp(:)
2888 : integer :: k
2889 0 : itmp => ptr
2890 0 : call get_integer_work_array(s, ptr, newsz, extra, ierr)
2891 0 : if (ierr /= 0) return
2892 0 : do k=1,min(oldsz,newsz)
2893 0 : ptr(k) = itmp(k)
2894 : end do
2895 0 : call return_integer_work_array(s, itmp)
2896 : end subroutine realloc_integer_work_array
2897 :
2898 :
2899 30 : subroutine get_integer_work_array(s, ptr, sz, extra, ierr)
2900 : type (star_info), pointer :: s
2901 : integer, intent(in) :: sz, extra
2902 : integer, pointer :: ptr(:)
2903 : integer, intent(out) :: ierr
2904 :
2905 : integer :: i
2906 : logical :: okay
2907 :
2908 30 : ierr = 0
2909 :
2910 : if (work_array_debug) then
2911 : allocate(ptr(sz + extra), stat=ierr)
2912 : return
2913 : end if
2914 :
2915 30 : okay = .false.
2916 60 : !$omp critical (alloc_integer_work_array1)
2917 30 : num_calls = num_calls + 1
2918 807 : do i=1,num_int_work_arrays
2919 807 : if (get1(i)) then
2920 : okay = .true.
2921 : exit
2922 : end if
2923 : end do
2924 : !$omp end critical (alloc_integer_work_array1)
2925 30 : if (okay) return
2926 :
2927 9 : allocate(ptr(sz + extra), stat=ierr)
2928 3 : num_allocs = num_allocs + 1
2929 :
2930 : if (work_array_trace) &
2931 : write(*,*) 'allocate new integer work array'
2932 :
2933 : contains
2934 :
2935 804 : logical function get1(itry)
2936 : integer, intent(in) :: itry
2937 804 : integer, pointer :: p(:)
2938 : include 'formats'
2939 804 : if (.not. associated(int_work_pointers(i)% p)) then
2940 804 : get1 = .false.
2941 : return
2942 : end if
2943 27 : p => int_work_pointers(i)% p
2944 27 : int_work_pointers(i)% p => null()
2945 27 : if (size(p,dim=1) < sz) then
2946 : if (work_array_trace) &
2947 : write(*,3) 'enlarge integer work array', size(p,dim=1), sz + extra
2948 0 : deallocate(p)
2949 0 : allocate(p(sz + extra), stat=ierr)
2950 : end if
2951 27 : ptr => p
2952 27 : get1 = .true.
2953 804 : end function get1
2954 :
2955 : end subroutine get_integer_work_array
2956 :
2957 :
2958 30 : subroutine return_integer_work_array(s, ptr)
2959 : type (star_info), pointer :: s
2960 : integer, pointer :: ptr(:)
2961 :
2962 : integer :: i
2963 : logical :: okay
2964 :
2965 60 : if (.not. associated(ptr)) return
2966 :
2967 : if (work_array_debug) then
2968 : deallocate(ptr)
2969 : return
2970 : end if
2971 :
2972 30 : okay = .false.
2973 60 : !$omp critical (alloc_integer_work_array2)
2974 30 : num_returns = num_returns + 1
2975 60 : do i=1,num_int_work_arrays
2976 60 : if (return1(i)) then
2977 : okay = .true.
2978 : exit
2979 : end if
2980 : end do
2981 : !$omp end critical (alloc_integer_work_array2)
2982 30 : if (okay) return
2983 :
2984 0 : deallocate(ptr)
2985 0 : num_deallocs = num_deallocs + 1
2986 :
2987 : contains
2988 :
2989 60 : logical function return1(itry)
2990 : integer, intent(in) :: itry
2991 60 : if (associated(int_work_pointers(itry)% p)) then
2992 60 : return1 = .false.
2993 : return
2994 : end if
2995 30 : int_work_pointers(itry)% p => ptr
2996 30 : ptr => null()
2997 30 : return1 = .true.
2998 30 : end function return1
2999 :
3000 : end subroutine return_integer_work_array
3001 :
3002 :
3003 10 : subroutine get_logical_work_array(s, ptr, sz, extra, ierr)
3004 : type (star_info), pointer :: s
3005 : integer, intent(in) :: sz, extra
3006 : logical, pointer :: ptr(:)
3007 : integer, intent(out) :: ierr
3008 :
3009 : integer :: i
3010 : logical :: okay
3011 :
3012 10 : ierr = 0
3013 :
3014 : if (work_array_debug) then
3015 : allocate(ptr(sz + extra), stat=ierr)
3016 9 : return
3017 : end if
3018 :
3019 10 : okay = .false.
3020 20 : !$omp critical (alloc_logical_work_array1)
3021 10 : num_calls = num_calls + 1
3022 260 : do i=1,num_logical_work_arrays
3023 260 : if (get1(i)) then
3024 : okay = .true.
3025 : exit
3026 : end if
3027 : end do
3028 : !$omp end critical (alloc_logical_work_array1)
3029 10 : if (okay) return
3030 :
3031 3 : allocate(ptr(sz + extra), stat=ierr)
3032 1 : num_allocs = num_allocs + 1
3033 :
3034 : if (work_array_trace) &
3035 : write(*,*) 'allocate new logical work array'
3036 :
3037 : contains
3038 :
3039 259 : logical function get1(itry)
3040 : integer, intent(in) :: itry
3041 259 : logical, pointer :: p(:)
3042 : include 'formats'
3043 259 : if (.not. associated(logical_work_pointers(itry)% p)) then
3044 259 : get1 = .false.
3045 : return
3046 : end if
3047 9 : p => logical_work_pointers(itry)% p
3048 9 : logical_work_pointers(itry)% p => null()
3049 9 : if (size(p,dim=1) < sz) then
3050 : if (work_array_trace) &
3051 : write(*,3) 'enlarge logical work array', size(p,dim=1), sz + extra
3052 0 : deallocate(p)
3053 0 : allocate(p(sz + extra), stat=ierr)
3054 : end if
3055 9 : ptr => p
3056 9 : get1 = .true.
3057 259 : end function get1
3058 :
3059 : end subroutine get_logical_work_array
3060 :
3061 :
3062 10 : subroutine return_logical_work_array(s, ptr)
3063 : type (star_info), pointer :: s
3064 : logical, pointer :: ptr(:)
3065 :
3066 : integer :: i
3067 : logical :: okay
3068 :
3069 20 : if (.not. associated(ptr)) return
3070 :
3071 : if (work_array_debug) then
3072 : deallocate(ptr)
3073 : return
3074 : end if
3075 :
3076 10 : okay = .false.
3077 20 : !$omp critical (alloc_logical_work_array2)
3078 10 : num_returns = num_returns + 1
3079 10 : do i=1,num_logical_work_arrays
3080 10 : if (return1(i)) then
3081 : okay = .true.
3082 : exit
3083 : end if
3084 : end do
3085 : !$omp end critical (alloc_logical_work_array2)
3086 10 : if (okay) return
3087 :
3088 0 : deallocate(ptr)
3089 0 : num_deallocs = num_deallocs + 1
3090 :
3091 : contains
3092 :
3093 10 : logical function return1(itry)
3094 : integer, intent(in) :: itry
3095 10 : if (associated(logical_work_pointers(itry)% p)) then
3096 10 : return1 = .false.
3097 : return
3098 : end if
3099 10 : logical_work_pointers(itry)% p => ptr
3100 10 : ptr => null()
3101 10 : return1 = .true.
3102 10 : end function return1
3103 :
3104 : end subroutine return_logical_work_array
3105 :
3106 :
3107 1 : subroutine shutdown_alloc ()
3108 :
3109 1 : call free_work_arrays()
3110 :
3111 1 : end subroutine shutdown_alloc
3112 :
3113 :
3114 1 : subroutine free_work_arrays ()
3115 :
3116 : integer :: i
3117 :
3118 251 : do i=1,num_work_arrays
3119 251 : if (associated(work_pointers(i)%p)) then
3120 8 : deallocate(work_pointers(i)%p)
3121 : nullify(work_pointers(i)%p)
3122 8 : num_deallocs = num_deallocs + 1
3123 : end if
3124 : end do
3125 251 : do i=1,num_int_work_arrays
3126 251 : if (associated(int_work_pointers(i)%p)) then
3127 3 : deallocate(int_work_pointers(i)%p)
3128 : nullify(int_work_pointers(i)%p)
3129 3 : num_deallocs = num_deallocs + 1
3130 : end if
3131 : end do
3132 251 : do i=1,num_logical_work_arrays
3133 251 : if (associated(logical_work_pointers(i)%p)) then
3134 1 : deallocate(logical_work_pointers(i)%p)
3135 : nullify(logical_work_pointers(i)%p)
3136 1 : num_deallocs = num_deallocs + 1
3137 : end if
3138 : end do
3139 :
3140 1 : end subroutine free_work_arrays
3141 :
3142 0 : subroutine size_work_arrays
3143 : integer :: sz, num, i
3144 :
3145 : include 'formats'
3146 0 : sz = 0; num = 0
3147 0 : do i=1,num_work_arrays
3148 0 : sz = sz + get_size(i)
3149 : end do
3150 0 : do i=1,num_int_work_arrays
3151 0 : sz = sz + get_size_i(i)
3152 : end do
3153 0 : do i=1,num_logical_work_arrays
3154 0 : sz = sz + get_size_l(i)
3155 : end do
3156 :
3157 : write(*,'(a,5x,99i8)') &
3158 0 : 'work_arrays: num sz calls returns diff', &
3159 0 : num, sz, num_calls, num_returns, num_calls-num_returns, &
3160 0 : num_allocs, num_deallocs, num_allocs-num_deallocs
3161 0 : write(*,'(A)')
3162 :
3163 : contains
3164 :
3165 0 : integer function get_size(i)
3166 : integer, intent(in) :: i
3167 0 : if (associated(work_pointers(i)% p)) then
3168 0 : get_size = size(work_pointers(i)% p,dim=1)
3169 0 : num = num + 1
3170 : else
3171 : get_size = 0
3172 : end if
3173 0 : end function get_size
3174 :
3175 0 : integer function get_size_i(i)
3176 : integer, intent(in) :: i
3177 0 : if (associated(int_work_pointers(i)% p)) then
3178 0 : get_size_i = size(int_work_pointers(i)% p,dim=1)
3179 0 : num = num + 1
3180 : else
3181 : get_size_i = 0
3182 : end if
3183 0 : end function get_size_i
3184 :
3185 0 : integer function get_size_l(i)
3186 : integer, intent(in) :: i
3187 0 : if (associated(logical_work_pointers(i)% p)) then
3188 0 : get_size_l = size(logical_work_pointers(i)% p,dim=1)
3189 0 : num = num + 1
3190 : else
3191 : get_size_l = 0
3192 : end if
3193 0 : end function get_size_l
3194 :
3195 : end subroutine size_work_arrays
3196 :
3197 : ! Cleans array used by history.f90, cant think of better place?
3198 1 : subroutine dealloc_history(s)
3199 : use utils_lib, only: integer_dict_free
3200 : type(star_info), pointer :: s
3201 :
3202 1 : if (associated(s% history_values)) then
3203 1 : deallocate(s% history_values)
3204 1 : nullify(s% history_values)
3205 : end if
3206 1 : if (associated(s% history_names)) then
3207 1 : deallocate(s% history_names)
3208 1 : nullify(s% history_names)
3209 : end if
3210 1 : if (associated(s% history_value_is_integer)) then
3211 1 : deallocate(s% history_value_is_integer)
3212 1 : nullify(s% history_value_is_integer)
3213 : end if
3214 1 : if (associated(s% history_names_dict)) then
3215 1 : call integer_dict_free(s% history_names_dict)
3216 1 : nullify(s% history_names_dict)
3217 : end if
3218 :
3219 1 : end subroutine dealloc_history
3220 :
3221 :
3222 0 : subroutine get_work_array(s, ptr, sz, extra, str, ierr)
3223 : type (star_info), pointer :: s
3224 : integer, intent(in) :: sz, extra
3225 : real(dp), pointer :: ptr(:)
3226 : character (len=*), intent(in) :: str
3227 : integer, intent(out) :: ierr
3228 0 : call do_get_work_array(s, .true., ptr, sz, extra, str, ierr)
3229 0 : end subroutine get_work_array
3230 :
3231 :
3232 0 : subroutine return_work_array(s, ptr, str)
3233 : type (star_info), pointer :: s
3234 : real(dp), pointer :: ptr(:)
3235 : character (len=*), intent(in) :: str
3236 0 : call do_return_work_array(s, .true., ptr, str)
3237 0 : end subroutine return_work_array
3238 :
3239 :
3240 : ! okay to use this if sure don't need reentrant allocation
3241 0 : subroutine non_crit_return_work_array(s, ptr, str)
3242 : type (star_info), pointer :: s
3243 : real(dp), pointer :: ptr(:)
3244 : character (len=*), intent(in) :: str
3245 0 : call do_return_work_array(s, .false., ptr, str)
3246 0 : end subroutine non_crit_return_work_array
3247 :
3248 0 : end module alloc
|
