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