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