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 set_flags
21 :
22 : use star_private_def
23 : use const_def, only: dp
24 : use utils_lib, only: is_bad
25 : use alloc
26 :
27 : implicit none
28 :
29 : contains
30 :
31 0 : subroutine set_v_flag(id, v_flag, ierr)
32 : integer, intent(in) :: id
33 : logical, intent(in) :: v_flag
34 : integer, intent(out) :: ierr
35 : type (star_info), pointer :: s
36 : integer :: nvar_hydro_old, k, nz, i_v, i_u
37 : logical, parameter :: dbg = .false.
38 :
39 : include 'formats'
40 :
41 : ierr = 0
42 0 : call get_star_ptr(id, s, ierr)
43 0 : if (ierr /= 0) return
44 :
45 0 : if (s% v_flag .eqv. v_flag) return
46 :
47 0 : nz = s% nz
48 0 : s% v_flag = v_flag
49 0 : nvar_hydro_old = s% nvar_hydro
50 :
51 0 : if (.not. v_flag) then ! remove i_v's
52 0 : call del(s% xh)
53 0 : call del(s% xh_start)
54 0 : if (associated(s% xh_old) .and. s% generations > 1) call del(s% xh_old)
55 : end if
56 :
57 0 : call set_var_info(s, ierr)
58 0 : if (ierr /= 0) return
59 :
60 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
61 0 : if (ierr /= 0) return
62 :
63 0 : call check_sizes(s, ierr)
64 0 : if (ierr /= 0) return
65 :
66 0 : if (v_flag) then ! insert i_v's
67 0 : i_v = s% i_v
68 0 : s% v_center = 0d0
69 0 : call insert(s% xh)
70 0 : call insert(s% xh_start)
71 0 : if (s% u_flag) then
72 0 : i_u = s% i_u
73 0 : do k=2,nz
74 0 : s% xh(i_v,k) = 0.5d0*(s% xh(i_u,k-1) + s% xh(i_u,k))
75 : end do
76 0 : s% xh(i_v,1) = s% xh(i_u,1)
77 0 : else if (s% RSP_flag) then
78 0 : s% xh(i_v,1:nz) = 0d0
79 0 : s% v(1:nz) = 0d0
80 : else
81 0 : do k=1,nz
82 0 : s% xh(i_v,k) = 0d0
83 : if (is_bad(s% xh(i_v,k))) s% xh(i_v,k) = 0d0
84 0 : s% v(k) = s% xh(i_v,k)
85 : end do
86 : end if
87 0 : if (associated(s% xh_old) .and. s% generations > 1) call insert(s% xh_old)
88 : end if
89 :
90 0 : call set_chem_names(s)
91 :
92 0 : if (v_flag .and. s% u_flag) then ! turn off u_flag when turn on v_flag
93 0 : call set_u_flag(id, .false., ierr)
94 : end if
95 :
96 : contains
97 :
98 0 : subroutine del(xs)
99 : real(dp) :: xs(:,:)
100 : integer :: j, i_v
101 0 : if (size(xs,dim=2) < nz) return
102 0 : i_v = s% i_v
103 0 : do j = i_v+1, nvar_hydro_old
104 0 : xs(j-1,1:nz) = xs(j,1:nz)
105 : end do
106 : end subroutine del
107 :
108 0 : subroutine insert(xs)
109 : real(dp) :: xs(:,:)
110 : integer :: j, i_v
111 0 : if (size(xs,dim=2) < nz) return
112 0 : i_v = s% i_v
113 0 : do j = s% nvar_hydro, i_v+1, -1
114 0 : xs(j,1:nz) = xs(j-1,1:nz)
115 : end do
116 0 : xs(i_v,1:nz) = 0
117 : end subroutine insert
118 :
119 : end subroutine set_v_flag
120 :
121 :
122 0 : subroutine set_u_flag(id, u_flag, ierr)
123 : integer, intent(in) :: id
124 : logical, intent(in) :: u_flag
125 : integer, intent(out) :: ierr
126 : type (star_info), pointer :: s
127 : integer :: nvar_hydro_old, k, nz, i_u, i_v
128 : logical, parameter :: dbg = .false.
129 :
130 : integer :: num_u_vars
131 :
132 : include 'formats'
133 :
134 : ierr = 0
135 0 : call get_star_ptr(id, s, ierr)
136 0 : if (ierr /= 0) return
137 :
138 0 : if (s% u_flag .eqv. u_flag) return
139 :
140 0 : nz = s% nz
141 0 : s% u_flag = u_flag
142 0 : nvar_hydro_old = s% nvar_hydro
143 :
144 0 : num_u_vars = 1
145 :
146 0 : if (.not. u_flag) then ! remove
147 0 : call del(s% xh)
148 0 : call del(s% xh_start)
149 0 : if (associated(s% xh_old) .and. s% generations > 1) call del(s% xh_old)
150 : end if
151 :
152 0 : call set_var_info(s, ierr)
153 0 : if (ierr /= 0) return
154 :
155 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
156 0 : if (ierr /= 0) return
157 :
158 0 : call check_sizes(s, ierr)
159 0 : if (ierr /= 0) return
160 :
161 0 : if (u_flag) then ! insert
162 0 : i_u = s% i_u
163 0 : call insert(s% xh)
164 0 : call insert(s% xh_start)
165 0 : if (s% v_flag) then ! use v to initialize u
166 0 : i_v = s% i_v
167 0 : do k=1,nz-1
168 0 : s% xh(i_u,k) = 0.5d0*(s% xh(i_v,k) + s% xh(i_v,k+1))
169 : end do
170 0 : k = nz
171 0 : s% xh(i_u,k) = 0.5d0*(s% xh(i_v,k) + s% v_center)
172 : else
173 0 : do k=1,nz
174 0 : s% xh(i_u,k) = 0d0
175 : end do
176 : end if
177 0 : if (associated(s% xh_old) .and. s% generations > 1) call insert(s% xh_old)
178 0 : call fill_ad_with_zeros(s% u_face_ad,1,-1)
179 0 : call fill_ad_with_zeros(s% P_face_ad,1,-1)
180 : end if
181 :
182 0 : call set_chem_names(s)
183 :
184 0 : if (u_flag .and. s% v_flag) then ! turn off v_flag when turn on u_flag
185 0 : call set_v_flag(id, .false., ierr)
186 : end if
187 :
188 : contains
189 :
190 0 : subroutine del(xs)
191 : real(dp) :: xs(:,:)
192 : integer :: k, j, i_u
193 0 : if (size(xs,dim=2) < nz) return
194 0 : i_u = s% i_u
195 0 : do k = 1, nz
196 0 : do j = i_u + num_u_vars, nvar_hydro_old
197 0 : xs(j-num_u_vars,k) = xs(j,k)
198 : end do
199 : end do
200 : end subroutine del
201 :
202 0 : subroutine insert(xs)
203 : real(dp) :: xs(:,:)
204 : integer :: k, j, i_u
205 0 : if (size(xs,dim=2) < nz) return
206 0 : i_u = s% i_u
207 0 : do k = 1, nz
208 0 : do j = s% nvar_hydro, i_u + num_u_vars, -1
209 0 : xs(j,k) = xs(j-num_u_vars,k)
210 : end do
211 0 : do j = i_u, i_u + num_u_vars - 1
212 0 : xs(j,k) = 0
213 : end do
214 : end do
215 :
216 : end subroutine insert
217 :
218 : end subroutine set_u_flag
219 :
220 :
221 0 : subroutine set_RTI_flag(id, RTI_flag, ierr)
222 : integer, intent(in) :: id
223 : logical, intent(in) :: RTI_flag
224 : integer, intent(out) :: ierr
225 : type (star_info), pointer :: s
226 : integer :: nvar_hydro_old, nz
227 : logical, parameter :: dbg = .false.
228 :
229 : include 'formats'
230 :
231 : ierr = 0
232 0 : call get_star_ptr(id, s, ierr)
233 0 : if (ierr /= 0) return
234 0 : if (s% RTI_flag .eqv. RTI_flag) return
235 :
236 0 : nz = s% nz
237 0 : s% RTI_flag = RTI_flag
238 0 : nvar_hydro_old = s% nvar_hydro
239 :
240 0 : if (.not. RTI_flag) then ! remove i_alpha_RTI's
241 0 : call del(s% xh)
242 0 : call del(s% xh_start)
243 0 : if (associated(s% xh_old) .and. s% generations > 1) call del(s% xh_old)
244 : end if
245 :
246 0 : call set_var_info(s, ierr)
247 0 : if (ierr /= 0) return
248 :
249 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
250 0 : if (ierr /= 0) return
251 :
252 0 : call check_sizes(s, ierr)
253 0 : if (ierr /= 0) return
254 :
255 0 : if (RTI_flag) then ! insert i_alpha_RTI's
256 0 : call insert(s% xh)
257 0 : call insert(s% xh_start)
258 0 : s% xh(s% i_alpha_RTI,1:nz) = 0d0
259 0 : if (associated(s% xh_old) .and. s% generations > 1) call insert(s% xh_old)
260 : end if
261 :
262 0 : call set_chem_names(s)
263 :
264 : contains
265 :
266 0 : subroutine del(xs)
267 : real(dp) :: xs(:,:)
268 : integer :: j, i_alpha_RTI
269 0 : if (size(xs,dim=2) < nz) return
270 0 : i_alpha_RTI = s% i_alpha_RTI
271 0 : do j = i_alpha_RTI+1, nvar_hydro_old
272 0 : xs(j-1,1:nz) = xs(j,1:nz)
273 : end do
274 : end subroutine del
275 :
276 0 : subroutine insert(xs)
277 : real(dp) :: xs(:,:)
278 : integer :: j, i_alpha_RTI
279 0 : if (size(xs,dim=2) < nz) return
280 0 : i_alpha_RTI = s% i_alpha_RTI
281 0 : do j = s% nvar_hydro, i_alpha_RTI+1, -1
282 0 : xs(j,1:nz) = xs(j-1,1:nz)
283 : end do
284 0 : xs(i_alpha_RTI,1:nz) = 0
285 : end subroutine insert
286 :
287 : end subroutine set_RTI_flag
288 :
289 :
290 0 : subroutine set_RSP2_flag(id, RSP2_flag, ierr)
291 : use const_def, only: sqrt_2_div_3
292 : use hydro_vars, only: set_vars
293 : use hydro_rsp2, only: set_RSP2_vars
294 : use hydro_rsp2_support, only: remesh_for_RSP2
295 : use star_utils, only: set_m_and_dm, set_dm_bar, set_qs
296 : integer, intent(in) :: id
297 : logical, intent(in) :: RSP2_flag
298 : integer, intent(out) :: ierr
299 : type (star_info), pointer :: s
300 : integer :: nvar_hydro_old, i, k, nz
301 : logical, parameter :: dbg = .false.
302 :
303 : include 'formats'
304 :
305 : ierr = 0
306 0 : call get_star_ptr(id, s, ierr)
307 0 : if (ierr /= 0) return
308 :
309 : !write(*,*) 'set_RSP2_flag previous s% RSP2_flag', s% RSP2_flag
310 : !write(*,*) 'set_RSP2_flag new RSP2_flag', RSP2_flag
311 0 : if (s% RSP2_flag .eqv. RSP2_flag) return
312 :
313 0 : nz = s% nz
314 :
315 0 : s% RSP2_flag = RSP2_flag
316 0 : nvar_hydro_old = s% nvar_hydro
317 :
318 0 : if (.not. RSP2_flag) then
319 0 : call remove1(s% i_w)
320 0 : call remove1(s% i_Hp)
321 : end if
322 :
323 0 : call set_var_info(s, ierr)
324 0 : if (ierr /= 0) return
325 :
326 0 : write(*,*) 'set_RSP2 variables and equations'
327 : if (.false.) then
328 : do i=1,s% nvar_hydro
329 : write(*,'(i3,2a20)') i, trim(s% nameofequ(i)), trim(s% nameofvar(i))
330 : end do
331 : end if
332 :
333 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
334 0 : if (ierr /= 0) return
335 :
336 0 : call check_sizes(s, ierr)
337 0 : if (ierr /= 0) return
338 :
339 0 : if (RSP2_flag) then
340 0 : call insert1(s% i_w)
341 0 : if (s% RSP_flag) then
342 0 : do k=1,nz
343 0 : s% xh(s% i_w,k) = sqrt(max(0d0,s% xh(s% i_Et_RSP,k)))
344 : end do
345 0 : else if (s% have_mlt_vc) then
346 0 : do k=1,nz-1
347 0 : s% xh(s% i_w,k) = 0.5d0*(s% mlt_vc(k) + s% mlt_vc(k+1))/sqrt_2_div_3
348 : end do
349 0 : s% xh(s% i_w,nz) = 0.5d0*s% mlt_vc(nz)/sqrt_2_div_3
350 : else
351 0 : write(*,*) 'set_rsp2_flag true requires mlt_vc'
352 0 : ierr = -1
353 0 : return
354 : end if
355 0 : call insert1(s% i_Hp) ! will be initialized by set_RSP2_vars
356 : end if
357 :
358 0 : call set_chem_names(s)
359 :
360 0 : if (.not. RSP2_flag) return
361 :
362 0 : if (s% RSP_flag) then ! turn off RSP_flag when turn on RSP2_flag
363 0 : call set_RSP_flag(id, .false., ierr)
364 0 : if (ierr /= 0) return
365 : end if
366 :
367 0 : call set_v_flag(s% id, .true., ierr)
368 0 : if (ierr /= 0) return
369 :
370 0 : call set_vars(s, s% dt, ierr)
371 0 : if (ierr /= 0) return
372 :
373 0 : call set_RSP2_vars(s,ierr)
374 0 : if (ierr /= 0) return
375 :
376 0 : if (s% RSP2_remesh_when_load) then
377 0 : write(*,*) 'doing automatic remesh for RSP2'
378 0 : call remesh_for_RSP2(s,ierr)
379 0 : if (ierr /= 0) return
380 0 : call set_qs(s, nz, s% q, s% dq, ierr)
381 0 : if (ierr /= 0) return
382 0 : call set_m_and_dm(s)
383 0 : call set_dm_bar(s, nz, s% dm, s% dm_bar)
384 0 : call set_vars(s, s% dt, ierr) ! redo after remesh_for_RSP2
385 0 : if (ierr /= 0) return
386 : end if
387 :
388 :
389 :
390 : contains
391 :
392 0 : subroutine insert1(i_var)
393 : integer, intent(in) :: i_var
394 : include 'formats'
395 0 : call insert(s% xh,i_var)
396 0 : call insert(s% xh_start,i_var)
397 0 : do k=1,nz
398 0 : s% xh(i_var,k) = 0d0
399 : end do
400 0 : if (associated(s% xh_old) .and. s% generations > 1) then
401 0 : call insert(s% xh_old,i_var)
402 : end if
403 0 : end subroutine insert1
404 :
405 0 : subroutine remove1(i_remove)
406 : integer, intent(in) :: i_remove
407 0 : call del(s% xh,i_remove)
408 0 : call del(s% xh_start,i_remove)
409 0 : if (associated(s% xh_old) .and. s% generations > 1) then
410 0 : call del(s% xh_old,i_remove)
411 : end if
412 0 : end subroutine remove1
413 :
414 0 : subroutine del(xs,i_var)
415 : real(dp) :: xs(:,:)
416 : integer, intent(in) :: i_var
417 : integer :: j, k
418 0 : if (size(xs,dim=2) < nz) return
419 0 : do j = i_var+1, nvar_hydro_old
420 0 : do k=1,nz
421 0 : xs(j-1,k) = xs(j,k)
422 : end do
423 : end do
424 : end subroutine del
425 :
426 0 : subroutine insert(xs,i_var)
427 : real(dp) :: xs(:,:)
428 : integer, intent(in) :: i_var
429 : integer :: j, k
430 0 : if (size(xs,dim=2) < nz) return
431 0 : do j = s% nvar_hydro, i_var+1, -1
432 0 : do k=1,nz
433 0 : xs(j,k) = xs(j-1,k)
434 : end do
435 : end do
436 0 : xs(i_var,1:nz) = 0d0
437 : end subroutine insert
438 :
439 : end subroutine set_RSP2_flag
440 :
441 :
442 0 : subroutine set_RSP_flag(id, RSP_flag, ierr)
443 : integer, intent(in) :: id
444 : logical, intent(in) :: RSP_flag
445 : integer, intent(out) :: ierr
446 : type (star_info), pointer :: s
447 : integer :: nvar_hydro_old, k, nz
448 : logical, parameter :: dbg = .false.
449 :
450 : include 'formats'
451 :
452 : ierr = 0
453 0 : call get_star_ptr(id, s, ierr)
454 0 : if (ierr /= 0) return
455 0 : if (s% RSP_flag .eqv. RSP_flag) return
456 :
457 0 : nz = s% nz
458 0 : s% RSP_flag = RSP_flag
459 0 : nvar_hydro_old = s% nvar_hydro
460 :
461 0 : if (.not. RSP_flag) then
462 0 : call remove1(s% i_Fr_RSP)
463 0 : call remove1(s% i_erad_RSP)
464 0 : call remove1(s% i_Et_RSP)
465 0 : else if (s% i_lum /= 0) then
466 0 : call remove1(s% i_lum)
467 : end if
468 :
469 0 : call set_var_info(s, ierr)
470 0 : if (ierr /= 0) return
471 :
472 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
473 0 : if (ierr /= 0) return
474 :
475 0 : call check_sizes(s, ierr)
476 0 : if (ierr /= 0) return
477 :
478 0 : if (RSP_flag) then
479 0 : call insert1(s% i_Et_RSP)
480 0 : call insert1(s% i_erad_RSP)
481 0 : call insert1(s% i_Fr_RSP)
482 : else
483 0 : call insert1(s% i_lum)
484 0 : do k=1,nz
485 0 : s% xh(s% i_lum,k) = s% L(k)
486 : end do
487 : end if
488 :
489 0 : call set_chem_names(s)
490 :
491 0 : if (RSP_flag) call set_v_flag(s% id, .true., ierr)
492 :
493 : contains
494 :
495 0 : subroutine insert1(i_var)
496 : integer, intent(in) :: i_var
497 0 : call insert(s% xh,i_var)
498 0 : call insert(s% xh_start,i_var)
499 0 : do k=1,nz
500 0 : s% xh(i_var,k) = 0d0
501 : end do
502 0 : if (associated(s% xh_old) .and. s% generations > 1) then
503 0 : call insert(s% xh_old,i_var)
504 : end if
505 0 : end subroutine insert1
506 :
507 0 : subroutine remove1(i_remove)
508 : integer, intent(in) :: i_remove
509 0 : call del(s% xh,i_remove)
510 0 : call del(s% xh_start,i_remove)
511 0 : if (associated(s% xh_old) .and. s% generations > 1) then
512 0 : call del(s% xh_old,i_remove)
513 : end if
514 0 : end subroutine remove1
515 :
516 0 : subroutine del(xs,i_var)
517 : real(dp) :: xs(:,:)
518 : integer, intent(in) :: i_var
519 : integer :: j, k
520 0 : if (size(xs,dim=2) < nz) return
521 0 : do j = i_var+1, nvar_hydro_old
522 0 : do k=1,nz
523 0 : xs(j-1,k) = xs(j,k)
524 : end do
525 : end do
526 : end subroutine del
527 :
528 0 : subroutine insert(xs,i_var)
529 : real(dp) :: xs(:,:)
530 : integer, intent(in) :: i_var
531 : integer :: j, k
532 0 : if (size(xs,dim=2) < nz) return
533 0 : do j = s% nvar_hydro, i_var+1, -1
534 0 : do k=1,nz
535 0 : xs(j,k) = xs(j-1,k)
536 : end do
537 : end do
538 0 : xs(i_var,1:nz) = 0
539 : end subroutine insert
540 :
541 : end subroutine set_RSP_flag
542 :
543 :
544 0 : subroutine set_w_div_wc_flag(id, w_div_wc_flag, ierr)
545 : integer, intent(in) :: id
546 : logical, intent(in) :: w_div_wc_flag
547 : integer, intent(out) :: ierr
548 : type (star_info), pointer :: s
549 : integer :: nvar_hydro_old, nz
550 : logical, parameter :: dbg = .false.
551 :
552 : include 'formats'
553 :
554 : ierr = 0
555 0 : call get_star_ptr(id, s, ierr)
556 0 : if (ierr /= 0) return
557 :
558 0 : if (s% w_div_wc_flag .eqv. w_div_wc_flag) return
559 :
560 0 : nz = s% nz
561 0 : s% w_div_wc_flag = w_div_wc_flag
562 0 : nvar_hydro_old = s% nvar_hydro
563 :
564 0 : if (.not. w_div_wc_flag) then ! remove i_w_div_wc's
565 0 : call del(s% xh)
566 0 : call del(s% xh_start)
567 0 : if (associated(s% xh_old) .and. s% generations > 1) call del(s% xh_old)
568 : end if
569 :
570 0 : call set_var_info(s, ierr)
571 0 : if (ierr /= 0) return
572 :
573 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
574 0 : if (ierr /= 0) return
575 :
576 0 : call check_sizes(s, ierr)
577 0 : if (ierr /= 0) return
578 :
579 0 : if (w_div_wc_flag) then ! insert i_w_div_w's
580 0 : call insert(s% xh)
581 0 : call insert(s% xh_start)
582 0 : s% xh(s% i_w_div_wc,1:nz) = 0d0
583 0 : if (associated(s% xh_old) .and. s% generations > 1) call insert(s% xh_old)
584 : end if
585 :
586 0 : call set_chem_names(s)
587 :
588 : contains
589 :
590 0 : subroutine del(xs)
591 : real(dp) :: xs(:,:)
592 : integer :: j, i_w_div_wc
593 0 : if (size(xs,dim=2) < nz) return
594 0 : i_w_div_wc = s% i_w_div_wc
595 0 : do j = i_w_div_wc+1, nvar_hydro_old
596 0 : xs(j-1,1:nz) = xs(j,1:nz)
597 : end do
598 : end subroutine del
599 :
600 0 : subroutine insert(xs)
601 : real(dp) :: xs(:,:)
602 : integer :: j, i_w_div_wc
603 0 : if (size(xs,dim=2) < nz) return
604 0 : i_w_div_wc = s% i_w_div_wc
605 0 : do j = s% nvar_hydro, i_w_div_wc+1, -1
606 0 : xs(j,1:nz) = xs(j-1,1:nz)
607 : end do
608 0 : xs(i_w_div_wc,1:nz) = 0
609 : end subroutine insert
610 :
611 : end subroutine set_w_div_wc_flag
612 :
613 :
614 0 : subroutine set_j_rot_flag(id, j_rot_flag, ierr)
615 : integer, intent(in) :: id
616 : logical, intent(in) :: j_rot_flag
617 : integer, intent(out) :: ierr
618 : type (star_info), pointer :: s
619 : integer :: nvar_hydro_old, nz
620 : logical, parameter :: dbg = .false.
621 :
622 : include 'formats'
623 :
624 : ierr = 0
625 0 : call get_star_ptr(id, s, ierr)
626 0 : if (ierr /= 0) return
627 :
628 0 : if (s% j_rot_flag .eqv. j_rot_flag) return
629 :
630 0 : nz = s% nz
631 0 : s% j_rot_flag = j_rot_flag
632 0 : nvar_hydro_old = s% nvar_hydro
633 :
634 0 : if (.not. j_rot_flag) then ! remove i_j_rot's
635 0 : call del(s% xh)
636 0 : call del(s% xh_start)
637 0 : if (associated(s% xh_old) .and. s% generations > 1) call del(s% xh_old)
638 : end if
639 :
640 0 : call set_var_info(s, ierr)
641 0 : if (ierr /= 0) return
642 :
643 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
644 0 : if (ierr /= 0) return
645 :
646 0 : call check_sizes(s, ierr)
647 0 : if (ierr /= 0) return
648 :
649 0 : if (j_rot_flag) then ! insert i_j_rot's
650 0 : call insert(s% xh)
651 0 : call insert(s% xh_start)
652 0 : s% xh(s% i_j_rot,1:nz) = 0d0
653 0 : if (associated(s% xh_old) .and. s% generations > 1) call insert(s% xh_old)
654 : end if
655 :
656 0 : call set_chem_names(s)
657 :
658 : contains
659 :
660 0 : subroutine del(xs)
661 : real(dp) :: xs(:,:)
662 : integer :: j, i_j_rot
663 0 : if (size(xs,dim=2) < nz) return
664 0 : i_j_rot = s% i_j_rot
665 0 : do j = i_j_rot+1, nvar_hydro_old
666 0 : xs(j-1,1:nz) = xs(j,1:nz)
667 : end do
668 : end subroutine del
669 :
670 0 : subroutine insert(xs)
671 : real(dp) :: xs(:,:)
672 : integer :: j, i_j_rot
673 0 : if (size(xs,dim=2) < nz) return
674 0 : i_j_rot = s% i_j_rot
675 0 : do j = s% nvar_hydro, i_j_rot+1, -1
676 0 : xs(j,1:nz) = xs(j-1,1:nz)
677 : end do
678 0 : xs(i_j_rot,1:nz) = 0
679 : end subroutine insert
680 :
681 : end subroutine set_j_rot_flag
682 :
683 :
684 0 : subroutine set_D_omega_flag(id, D_omega_flag, ierr)
685 : integer, intent(in) :: id
686 : logical, intent(in) :: D_omega_flag
687 : integer, intent(out) :: ierr
688 : type (star_info), pointer :: s
689 : include 'formats'
690 : ierr = 0
691 0 : call get_star_ptr(id, s, ierr)
692 0 : if (ierr /= 0) return
693 0 : if (s% D_omega_flag .eqv. D_omega_flag) return
694 0 : s% D_omega_flag = D_omega_flag
695 0 : s% D_omega(1:s% nz) = 0
696 : end subroutine set_D_omega_flag
697 :
698 :
699 0 : subroutine set_am_nu_rot_flag(id, am_nu_rot_flag, ierr)
700 : integer, intent(in) :: id
701 : logical, intent(in) :: am_nu_rot_flag
702 : integer, intent(out) :: ierr
703 : type (star_info), pointer :: s
704 : include 'formats'
705 : ierr = 0
706 0 : call get_star_ptr(id, s, ierr)
707 0 : if (ierr /= 0) return
708 0 : if (s% am_nu_rot_flag .eqv. am_nu_rot_flag) return
709 0 : s% am_nu_rot_flag = am_nu_rot_flag
710 0 : s% am_nu_rot(1:s% nz) = 0
711 : end subroutine set_am_nu_rot_flag
712 :
713 :
714 0 : subroutine set_rotation_flag(id, rotation_flag, ierr)
715 : integer, intent(in) :: id
716 : logical, intent(in) :: rotation_flag
717 : integer, intent(out) :: ierr
718 : type (star_info), pointer :: s
719 :
720 : include 'formats'
721 :
722 : ierr = 0
723 0 : call get_star_ptr(id, s, ierr)
724 0 : if (ierr /= 0) return
725 0 : if (s% rotation_flag .eqv. rotation_flag) return
726 :
727 0 : s% rotation_flag = rotation_flag
728 0 : s% omega(1:s% nz) = 0
729 0 : s% j_rot(1:s% nz) = 0
730 0 : s% D_omega(1:s% nz) = 0
731 0 : s% am_nu_rot(1:s% nz) = 0
732 :
733 0 : if (.not. rotation_flag) then
734 0 : call set_w_div_wc_flag(id, .false., ierr)
735 0 : if (ierr /= 0) return
736 0 : call set_j_rot_flag(id, .false., ierr)
737 : if (ierr /= 0) return
738 0 : return
739 : end if
740 :
741 0 : if (s% job% use_w_div_wc_flag_with_rotation) then
742 0 : call set_w_div_wc_flag(id, .true., ierr)
743 0 : if (ierr /= 0) return
744 0 : if (s% job% use_j_rot_flag_with_rotation) then
745 0 : call set_j_rot_flag(id, .true., ierr)
746 0 : if (ierr /= 0) return
747 : end if
748 : end if
749 :
750 0 : call zero_array(s% nu_ST)
751 0 : call zero_array(s% D_ST)
752 0 : call zero_array(s% D_DSI)
753 0 : call zero_array(s% D_SH)
754 0 : call zero_array(s% D_SSI)
755 0 : call zero_array(s% D_ES)
756 0 : call zero_array(s% D_GSF)
757 :
758 0 : call zero_array(s% prev_mesh_omega)
759 0 : call zero_array(s% prev_mesh_j_rot)
760 :
761 :
762 : contains
763 :
764 0 : subroutine zero_array(d)
765 : real(dp), pointer :: d(:)
766 0 : if (.not. associated(d)) return
767 0 : d(:) = 0
768 : end subroutine zero_array
769 :
770 : end subroutine set_rotation_flag
771 :
772 : end module set_flags
|
