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 :
189 : contains
190 :
191 0 : subroutine del(xs)
192 : real(dp) :: xs(:,:)
193 : integer :: k, j, i_u
194 0 : if (size(xs,dim=2) < nz) return
195 0 : i_u = s% i_u
196 0 : do k = 1, nz
197 0 : do j = i_u + num_u_vars, nvar_hydro_old
198 0 : xs(j-num_u_vars,k) = xs(j,k)
199 : end do
200 : end do
201 : end subroutine del
202 :
203 0 : subroutine insert(xs)
204 : real(dp) :: xs(:,:)
205 : integer :: k, j, i_u
206 0 : if (size(xs,dim=2) < nz) return
207 0 : i_u = s% i_u
208 0 : do k = 1, nz
209 0 : do j = s% nvar_hydro, i_u + num_u_vars, -1
210 0 : xs(j,k) = xs(j-num_u_vars,k)
211 : end do
212 0 : do j = i_u, i_u + num_u_vars - 1
213 0 : xs(j,k) = 0
214 : end do
215 : end do
216 :
217 : end subroutine insert
218 :
219 : end subroutine set_u_flag
220 :
221 :
222 0 : subroutine set_RTI_flag(id, RTI_flag, ierr)
223 : integer, intent(in) :: id
224 : logical, intent(in) :: RTI_flag
225 : integer, intent(out) :: ierr
226 : type (star_info), pointer :: s
227 : integer :: nvar_hydro_old, nz
228 : logical, parameter :: dbg = .false.
229 :
230 : include 'formats'
231 :
232 : ierr = 0
233 0 : call get_star_ptr(id, s, ierr)
234 0 : if (ierr /= 0) return
235 0 : if (s% RTI_flag .eqv. RTI_flag) return
236 :
237 0 : nz = s% nz
238 0 : s% RTI_flag = RTI_flag
239 0 : nvar_hydro_old = s% nvar_hydro
240 :
241 0 : if (.not. RTI_flag) then ! remove i_alpha_RTI's
242 0 : call del(s% xh)
243 0 : call del(s% xh_start)
244 0 : if (associated(s% xh_old) .and. s% generations > 1) call del(s% xh_old)
245 : end if
246 :
247 0 : call set_var_info(s, ierr)
248 0 : if (ierr /= 0) return
249 :
250 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
251 0 : if (ierr /= 0) return
252 :
253 0 : call check_sizes(s, ierr)
254 0 : if (ierr /= 0) return
255 :
256 0 : if (RTI_flag) then ! insert i_alpha_RTI's
257 0 : call insert(s% xh)
258 0 : call insert(s% xh_start)
259 0 : s% xh(s% i_alpha_RTI,1:nz) = 0d0
260 0 : if (associated(s% xh_old) .and. s% generations > 1) call insert(s% xh_old)
261 : end if
262 :
263 0 : call set_chem_names(s)
264 :
265 : contains
266 :
267 0 : subroutine del(xs)
268 : real(dp) :: xs(:,:)
269 : integer :: j, i_alpha_RTI
270 0 : if (size(xs,dim=2) < nz) return
271 0 : i_alpha_RTI = s% i_alpha_RTI
272 0 : do j = i_alpha_RTI+1, nvar_hydro_old
273 0 : xs(j-1,1:nz) = xs(j,1:nz)
274 : end do
275 : end subroutine del
276 :
277 0 : subroutine insert(xs)
278 : real(dp) :: xs(:,:)
279 : integer :: j, i_alpha_RTI
280 0 : if (size(xs,dim=2) < nz) return
281 0 : i_alpha_RTI = s% i_alpha_RTI
282 0 : do j = s% nvar_hydro, i_alpha_RTI+1, -1
283 0 : xs(j,1:nz) = xs(j-1,1:nz)
284 : end do
285 0 : xs(i_alpha_RTI,1:nz) = 0
286 : end subroutine insert
287 :
288 : end subroutine set_RTI_flag
289 :
290 :
291 0 : subroutine set_TDC_to_RSP2_mesh(id, ierr) ! this is the remeshing function called from starlib
292 : use tdc_hydro_support, only: remesh_for_TDC_pulsations
293 : use hydro_vars, only: set_vars
294 : use star_utils, only: set_m_and_dm, set_dm_bar, set_qs
295 : integer, intent(in) :: id
296 : integer, intent(out) :: ierr
297 : type (star_info), pointer :: s
298 : integer :: nvar_hydro_old, i, k, nz
299 : logical, parameter :: dbg = .false.
300 :
301 : include 'formats'
302 :
303 : ierr = 0
304 0 : call get_star_ptr(id, s, ierr)
305 0 : if (ierr /= 0) return
306 :
307 :
308 0 : nz = s% nz
309 :
310 0 : nvar_hydro_old = s% nvar_hydro
311 :
312 0 : write(*,*) 'doing automatic RSP style remesh for TDC Pulsations'
313 0 : call remesh_for_TDC_pulsations(s,ierr)
314 0 : if (ierr /= 0) return
315 0 : call set_qs(s, nz, s% q, s% dq, ierr)
316 0 : if (ierr /= 0) return
317 0 : call set_m_and_dm(s)
318 0 : call set_dm_bar(s, nz, s% dm, s% dm_bar)
319 0 : call set_vars(s, s% dt, ierr) ! redo after remesh_for_RSP2
320 0 : if (ierr /= 0) return
321 :
322 0 : end subroutine set_TDC_to_RSP2_mesh
323 :
324 0 : subroutine set_RSP2_flag(id, RSP2_flag, ierr)
325 0 : use const_def, only: sqrt_2_div_3
326 : use hydro_vars, only: set_vars
327 : use hydro_rsp2, only: set_RSP2_vars
328 : use hydro_rsp2_support, only: remesh_for_RSP2
329 : use star_utils, only: set_m_and_dm, set_dm_bar, set_qs
330 : integer, intent(in) :: id
331 : logical, intent(in) :: RSP2_flag
332 : integer, intent(out) :: ierr
333 : type (star_info), pointer :: s
334 : integer :: nvar_hydro_old, i, k, nz
335 : logical, parameter :: dbg = .false.
336 :
337 : include 'formats'
338 :
339 : ierr = 0
340 0 : call get_star_ptr(id, s, ierr)
341 0 : if (ierr /= 0) return
342 :
343 : !write(*,*) 'set_RSP2_flag previous s% RSP2_flag', s% RSP2_flag
344 : !write(*,*) 'set_RSP2_flag new RSP2_flag', RSP2_flag
345 0 : if (s% RSP2_flag .eqv. RSP2_flag) return
346 :
347 0 : nz = s% nz
348 :
349 0 : s% RSP2_flag = RSP2_flag
350 0 : nvar_hydro_old = s% nvar_hydro
351 :
352 0 : if (.not. RSP2_flag) then
353 0 : call remove1(s% i_w)
354 0 : call remove1(s% i_Hp)
355 : end if
356 :
357 0 : call set_var_info(s, ierr)
358 0 : if (ierr /= 0) return
359 :
360 0 : write(*,*) 'set_RSP2 variables and equations'
361 : if (.false.) then
362 : do i=1,s% nvar_hydro
363 : write(*,'(i3,2a20)') i, trim(s% nameofequ(i)), trim(s% nameofvar(i))
364 : end do
365 : end if
366 :
367 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
368 0 : if (ierr /= 0) return
369 :
370 0 : call check_sizes(s, ierr)
371 0 : if (ierr /= 0) return
372 :
373 0 : if (RSP2_flag) then
374 0 : call insert1(s% i_w)
375 0 : if (s% RSP_flag) then
376 0 : do k=1,nz
377 0 : s% xh(s% i_w,k) = sqrt(max(0d0,s% xh(s% i_Et_RSP,k)))
378 : end do
379 0 : else if (s% have_mlt_vc) then
380 0 : do k=1,nz-1
381 0 : s% xh(s% i_w,k) = 0.5d0*(s% mlt_vc(k) + s% mlt_vc(k+1))/sqrt_2_div_3
382 : end do
383 0 : s% xh(s% i_w,nz) = 0.5d0*s% mlt_vc(nz)/sqrt_2_div_3
384 : else
385 0 : write(*,*) 'set_rsp2_flag true requires mlt_vc'
386 0 : ierr = -1
387 0 : return
388 : end if
389 0 : call insert1(s% i_Hp) ! will be initialized by set_RSP2_vars
390 : end if
391 :
392 0 : call set_chem_names(s)
393 :
394 0 : if (.not. RSP2_flag) return
395 :
396 0 : if (s% RSP_flag) then ! turn off RSP_flag when turn on RSP2_flag
397 0 : call set_RSP_flag(id, .false., ierr)
398 0 : if (ierr /= 0) return
399 : end if
400 :
401 0 : call set_v_flag(s% id, .true., ierr)
402 0 : if (ierr /= 0) return
403 :
404 0 : call set_vars(s, s% dt, ierr)
405 0 : if (ierr /= 0) return
406 :
407 0 : call set_RSP2_vars(s,ierr)
408 0 : if (ierr /= 0) return
409 :
410 0 : if (s% RSP2_remesh_when_load) then
411 0 : write(*,*) 'doing automatic remesh for RSP2'
412 0 : call remesh_for_RSP2(s,ierr)
413 0 : if (ierr /= 0) return
414 0 : call set_qs(s, nz, s% q, s% dq, ierr)
415 0 : if (ierr /= 0) return
416 0 : call set_m_and_dm(s)
417 0 : call set_dm_bar(s, nz, s% dm, s% dm_bar)
418 0 : call set_vars(s, s% dt, ierr) ! redo after remesh_for_RSP2
419 0 : if (ierr /= 0) return
420 : end if
421 :
422 :
423 :
424 : contains
425 :
426 0 : subroutine insert1(i_var)
427 : integer, intent(in) :: i_var
428 : include 'formats'
429 0 : call insert(s% xh,i_var)
430 0 : call insert(s% xh_start,i_var)
431 0 : do k=1,nz
432 0 : s% xh(i_var,k) = 0d0
433 : end do
434 0 : if (associated(s% xh_old) .and. s% generations > 1) then
435 0 : call insert(s% xh_old,i_var)
436 : end if
437 0 : end subroutine insert1
438 :
439 0 : subroutine remove1(i_remove)
440 : integer, intent(in) :: i_remove
441 0 : call del(s% xh,i_remove)
442 0 : call del(s% xh_start,i_remove)
443 0 : if (associated(s% xh_old) .and. s% generations > 1) then
444 0 : call del(s% xh_old,i_remove)
445 : end if
446 0 : end subroutine remove1
447 :
448 0 : subroutine del(xs,i_var)
449 : real(dp) :: xs(:,:)
450 : integer, intent(in) :: i_var
451 : integer :: j, k
452 0 : if (size(xs,dim=2) < nz) return
453 0 : do j = i_var+1, nvar_hydro_old
454 0 : do k=1,nz
455 0 : xs(j-1,k) = xs(j,k)
456 : end do
457 : end do
458 : end subroutine del
459 :
460 0 : subroutine insert(xs,i_var)
461 : real(dp) :: xs(:,:)
462 : integer, intent(in) :: i_var
463 : integer :: j, k
464 0 : if (size(xs,dim=2) < nz) return
465 0 : do j = s% nvar_hydro, i_var+1, -1
466 0 : do k=1,nz
467 0 : xs(j,k) = xs(j-1,k)
468 : end do
469 : end do
470 0 : xs(i_var,1:nz) = 0d0
471 : end subroutine insert
472 :
473 : end subroutine set_RSP2_flag
474 :
475 :
476 0 : subroutine set_RSP_flag(id, RSP_flag, ierr)
477 : integer, intent(in) :: id
478 : logical, intent(in) :: RSP_flag
479 : integer, intent(out) :: ierr
480 : type (star_info), pointer :: s
481 : integer :: nvar_hydro_old, k, nz
482 : logical, parameter :: dbg = .false.
483 :
484 : include 'formats'
485 :
486 : ierr = 0
487 0 : call get_star_ptr(id, s, ierr)
488 0 : if (ierr /= 0) return
489 0 : if (s% RSP_flag .eqv. RSP_flag) return
490 :
491 0 : nz = s% nz
492 0 : s% RSP_flag = RSP_flag
493 0 : nvar_hydro_old = s% nvar_hydro
494 :
495 0 : if (.not. RSP_flag) then
496 0 : call remove1(s% i_Fr_RSP)
497 0 : call remove1(s% i_erad_RSP)
498 0 : call remove1(s% i_Et_RSP)
499 0 : else if (s% i_lum /= 0) then
500 0 : call remove1(s% i_lum)
501 : end if
502 :
503 0 : call set_var_info(s, ierr)
504 0 : if (ierr /= 0) return
505 :
506 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
507 0 : if (ierr /= 0) return
508 :
509 0 : call check_sizes(s, ierr)
510 0 : if (ierr /= 0) return
511 :
512 0 : if (RSP_flag) then
513 0 : call insert1(s% i_Et_RSP)
514 0 : call insert1(s% i_erad_RSP)
515 0 : call insert1(s% i_Fr_RSP)
516 : else
517 0 : call insert1(s% i_lum)
518 0 : do k=1,nz
519 0 : s% xh(s% i_lum,k) = s% L(k)
520 : end do
521 : end if
522 :
523 0 : call set_chem_names(s)
524 :
525 0 : if (RSP_flag) call set_v_flag(s% id, .true., ierr)
526 :
527 : contains
528 :
529 0 : subroutine insert1(i_var)
530 : integer, intent(in) :: i_var
531 0 : call insert(s% xh,i_var)
532 0 : call insert(s% xh_start,i_var)
533 0 : do k=1,nz
534 0 : s% xh(i_var,k) = 0d0
535 : end do
536 0 : if (associated(s% xh_old) .and. s% generations > 1) then
537 0 : call insert(s% xh_old,i_var)
538 : end if
539 0 : end subroutine insert1
540 :
541 0 : subroutine remove1(i_remove)
542 : integer, intent(in) :: i_remove
543 0 : call del(s% xh,i_remove)
544 0 : call del(s% xh_start,i_remove)
545 0 : if (associated(s% xh_old) .and. s% generations > 1) then
546 0 : call del(s% xh_old,i_remove)
547 : end if
548 0 : end subroutine remove1
549 :
550 0 : subroutine del(xs,i_var)
551 : real(dp) :: xs(:,:)
552 : integer, intent(in) :: i_var
553 : integer :: j, k
554 0 : if (size(xs,dim=2) < nz) return
555 0 : do j = i_var+1, nvar_hydro_old
556 0 : do k=1,nz
557 0 : xs(j-1,k) = xs(j,k)
558 : end do
559 : end do
560 : end subroutine del
561 :
562 0 : subroutine insert(xs,i_var)
563 : real(dp) :: xs(:,:)
564 : integer, intent(in) :: i_var
565 : integer :: j, k
566 0 : if (size(xs,dim=2) < nz) return
567 0 : do j = s% nvar_hydro, i_var+1, -1
568 0 : do k=1,nz
569 0 : xs(j,k) = xs(j-1,k)
570 : end do
571 : end do
572 0 : xs(i_var,1:nz) = 0
573 : end subroutine insert
574 :
575 : end subroutine set_RSP_flag
576 :
577 :
578 0 : subroutine set_w_div_wc_flag(id, w_div_wc_flag, ierr)
579 : integer, intent(in) :: id
580 : logical, intent(in) :: w_div_wc_flag
581 : integer, intent(out) :: ierr
582 : type (star_info), pointer :: s
583 : integer :: nvar_hydro_old, nz
584 : logical, parameter :: dbg = .false.
585 :
586 : include 'formats'
587 :
588 : ierr = 0
589 0 : call get_star_ptr(id, s, ierr)
590 0 : if (ierr /= 0) return
591 :
592 0 : if (s% w_div_wc_flag .eqv. w_div_wc_flag) return
593 :
594 0 : nz = s% nz
595 0 : s% w_div_wc_flag = w_div_wc_flag
596 0 : nvar_hydro_old = s% nvar_hydro
597 :
598 0 : if (.not. w_div_wc_flag) then ! remove i_w_div_wc's
599 0 : call del(s% xh)
600 0 : call del(s% xh_start)
601 0 : if (associated(s% xh_old) .and. s% generations > 1) call del(s% xh_old)
602 : end if
603 :
604 0 : call set_var_info(s, ierr)
605 0 : if (ierr /= 0) return
606 :
607 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
608 0 : if (ierr /= 0) return
609 :
610 0 : call check_sizes(s, ierr)
611 0 : if (ierr /= 0) return
612 :
613 0 : if (w_div_wc_flag) then ! insert i_w_div_w's
614 0 : call insert(s% xh)
615 0 : call insert(s% xh_start)
616 0 : s% xh(s% i_w_div_wc,1:nz) = 0d0
617 0 : if (associated(s% xh_old) .and. s% generations > 1) call insert(s% xh_old)
618 : end if
619 :
620 0 : call set_chem_names(s)
621 :
622 : contains
623 :
624 0 : subroutine del(xs)
625 : real(dp) :: xs(:,:)
626 : integer :: j, i_w_div_wc
627 0 : if (size(xs,dim=2) < nz) return
628 0 : i_w_div_wc = s% i_w_div_wc
629 0 : do j = i_w_div_wc+1, nvar_hydro_old
630 0 : xs(j-1,1:nz) = xs(j,1:nz)
631 : end do
632 : end subroutine del
633 :
634 0 : subroutine insert(xs)
635 : real(dp) :: xs(:,:)
636 : integer :: j, i_w_div_wc
637 0 : if (size(xs,dim=2) < nz) return
638 0 : i_w_div_wc = s% i_w_div_wc
639 0 : do j = s% nvar_hydro, i_w_div_wc+1, -1
640 0 : xs(j,1:nz) = xs(j-1,1:nz)
641 : end do
642 0 : xs(i_w_div_wc,1:nz) = 0
643 : end subroutine insert
644 :
645 : end subroutine set_w_div_wc_flag
646 :
647 :
648 0 : subroutine set_j_rot_flag(id, j_rot_flag, ierr)
649 : integer, intent(in) :: id
650 : logical, intent(in) :: j_rot_flag
651 : integer, intent(out) :: ierr
652 : type (star_info), pointer :: s
653 : integer :: nvar_hydro_old, nz
654 : logical, parameter :: dbg = .false.
655 :
656 : include 'formats'
657 :
658 : ierr = 0
659 0 : call get_star_ptr(id, s, ierr)
660 0 : if (ierr /= 0) return
661 :
662 0 : if (s% j_rot_flag .eqv. j_rot_flag) return
663 :
664 0 : nz = s% nz
665 0 : s% j_rot_flag = j_rot_flag
666 0 : nvar_hydro_old = s% nvar_hydro
667 :
668 0 : if (.not. j_rot_flag) then ! remove i_j_rot's
669 0 : call del(s% xh)
670 0 : call del(s% xh_start)
671 0 : if (associated(s% xh_old) .and. s% generations > 1) call del(s% xh_old)
672 : end if
673 :
674 0 : call set_var_info(s, ierr)
675 0 : if (ierr /= 0) return
676 :
677 0 : call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr)
678 0 : if (ierr /= 0) return
679 :
680 0 : call check_sizes(s, ierr)
681 0 : if (ierr /= 0) return
682 :
683 0 : if (j_rot_flag) then ! insert i_j_rot's
684 0 : call insert(s% xh)
685 0 : call insert(s% xh_start)
686 0 : s% xh(s% i_j_rot,1:nz) = 0d0
687 0 : if (associated(s% xh_old) .and. s% generations > 1) call insert(s% xh_old)
688 : end if
689 :
690 0 : call set_chem_names(s)
691 :
692 : contains
693 :
694 0 : subroutine del(xs)
695 : real(dp) :: xs(:,:)
696 : integer :: j, i_j_rot
697 0 : if (size(xs,dim=2) < nz) return
698 0 : i_j_rot = s% i_j_rot
699 0 : do j = i_j_rot+1, nvar_hydro_old
700 0 : xs(j-1,1:nz) = xs(j,1:nz)
701 : end do
702 : end subroutine del
703 :
704 0 : subroutine insert(xs)
705 : real(dp) :: xs(:,:)
706 : integer :: j, i_j_rot
707 0 : if (size(xs,dim=2) < nz) return
708 0 : i_j_rot = s% i_j_rot
709 0 : do j = s% nvar_hydro, i_j_rot+1, -1
710 0 : xs(j,1:nz) = xs(j-1,1:nz)
711 : end do
712 0 : xs(i_j_rot,1:nz) = 0
713 : end subroutine insert
714 :
715 : end subroutine set_j_rot_flag
716 :
717 :
718 0 : subroutine set_D_omega_flag(id, D_omega_flag, ierr)
719 : integer, intent(in) :: id
720 : logical, intent(in) :: D_omega_flag
721 : integer, intent(out) :: ierr
722 : type (star_info), pointer :: s
723 : include 'formats'
724 : ierr = 0
725 0 : call get_star_ptr(id, s, ierr)
726 0 : if (ierr /= 0) return
727 0 : if (s% D_omega_flag .eqv. D_omega_flag) return
728 0 : s% D_omega_flag = D_omega_flag
729 0 : s% D_omega(1:s% nz) = 0
730 : end subroutine set_D_omega_flag
731 :
732 :
733 0 : subroutine set_am_nu_rot_flag(id, am_nu_rot_flag, ierr)
734 : integer, intent(in) :: id
735 : logical, intent(in) :: am_nu_rot_flag
736 : integer, intent(out) :: ierr
737 : type (star_info), pointer :: s
738 : include 'formats'
739 : ierr = 0
740 0 : call get_star_ptr(id, s, ierr)
741 0 : if (ierr /= 0) return
742 0 : if (s% am_nu_rot_flag .eqv. am_nu_rot_flag) return
743 0 : s% am_nu_rot_flag = am_nu_rot_flag
744 0 : s% am_nu_rot(1:s% nz) = 0
745 : end subroutine set_am_nu_rot_flag
746 :
747 :
748 0 : subroutine set_rotation_flag(id, rotation_flag, ierr)
749 : integer, intent(in) :: id
750 : logical, intent(in) :: rotation_flag
751 : integer, intent(out) :: ierr
752 : type (star_info), pointer :: s
753 :
754 : include 'formats'
755 :
756 : ierr = 0
757 0 : call get_star_ptr(id, s, ierr)
758 0 : if (ierr /= 0) return
759 0 : if (s% rotation_flag .eqv. rotation_flag) return
760 :
761 0 : s% rotation_flag = rotation_flag
762 0 : s% omega(1:s% nz) = 0
763 0 : s% j_rot(1:s% nz) = 0
764 0 : s% D_omega(1:s% nz) = 0
765 0 : s% am_nu_rot(1:s% nz) = 0
766 :
767 0 : if (.not. rotation_flag) then
768 0 : call set_w_div_wc_flag(id, .false., ierr)
769 0 : if (ierr /= 0) return
770 0 : call set_j_rot_flag(id, .false., ierr)
771 : if (ierr /= 0) return
772 0 : return
773 : end if
774 :
775 0 : if (s% job% use_w_div_wc_flag_with_rotation) then
776 0 : call set_w_div_wc_flag(id, .true., ierr)
777 0 : if (ierr /= 0) return
778 0 : if (s% job% use_j_rot_flag_with_rotation) then
779 0 : call set_j_rot_flag(id, .true., ierr)
780 0 : if (ierr /= 0) return
781 : end if
782 : end if
783 :
784 0 : call zero_array(s% nu_ST)
785 0 : call zero_array(s% D_ST)
786 0 : call zero_array(s% D_DSI)
787 0 : call zero_array(s% D_SH)
788 0 : call zero_array(s% D_SSI)
789 0 : call zero_array(s% D_ES)
790 0 : call zero_array(s% D_GSF)
791 :
792 0 : call zero_array(s% prev_mesh_omega)
793 0 : call zero_array(s% prev_mesh_j_rot)
794 :
795 :
796 : contains
797 :
798 0 : subroutine zero_array(d)
799 : real(dp), pointer :: d(:)
800 0 : if (.not. associated(d)) return
801 0 : d(:) = 0
802 : end subroutine zero_array
803 :
804 : end subroutine set_rotation_flag
805 :
806 : end module set_flags
|
