diff --git a/runTimeTests.sh b/runTimeTests.sh new file mode 100644 index 0000000000..b282e6411d --- /dev/null +++ b/runTimeTests.sh @@ -0,0 +1,4 @@ +#!bash + +for i in (0, 1, 2, 3, 4, 5, 6, 7, 8, 9) + ./mfc.sh run ../MonopoleTests/1C0780C8Big/case.py -n 6 -g 6 -t pre_process simulation diff --git a/src/simulation/m_bubbles.f90 b/src/simulation/m_bubbles.f90 index 6fdf5c00d4..8b71e918ba 100644 --- a/src/simulation/m_bubbles.f90 +++ b/src/simulation/m_bubbles.f90 @@ -22,7 +22,11 @@ module m_bubbles real(kind(0.d0)) :: chi_vw !< Bubble wall properties (Ando 2010) real(kind(0.d0)) :: k_mw !< Bubble wall properties (Ando 2010) real(kind(0.d0)) :: rho_mw !< Bubble wall properties (Ando 2010) -!$acc declare create(chi_vw, k_mw, rho_mw) + !$acc declare create(chi_vw, k_mw, rho_mw) + + integer, allocatable, dimension(:) :: rs, vs, ms, ps + !$acc declare create(rs, vs, ms, ps) + contains @@ -37,20 +41,51 @@ module m_bubbles !! @param bub_v_src Bubble velocity equation source !! @param bub_p_src Bubble pressure equation source !! @param bub_m_src Bubble mass equation source - subroutine s_compute_bubble_source(idir, q_prim_vf, q_cons_vf, mydivu, & - bub_adv_src, bub_r_src, bub_v_src, bub_p_src, bub_m_src) + + subroutine s_initialize_bubbles_module() + + integer :: i, j, k, l, q + + allocate (rs(1:nb)) + allocate (vs(1:nb)) + if (.not. polytropic) then + allocate (ps(1:nb)) + allocate (ms(1:nb)) + end if + + do l = 1, nb + rs(l) = bub_idx%rs(l) + vs(l) = bub_idx%vs(l) + if (.not. polytropic) then + ps(l) = bub_idx%ps(l) + ms(l) = bub_idx%ms(l) + end if + end do + + !$acc update device(rs, vs) + if (.not. polytropic) then + !$acc update device(ps, ms) + end if + + end subroutine + + + subroutine s_compute_bubble_source(bub_adv_src, bub_r_src, bub_v_src, bub_p_src, bub_m_src, divu, nbub, & + q_cons_vf, q_prim_vf, t_step, id, rhs_vf) type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf, q_cons_vf - type(scalar_field), intent(IN) :: mydivu - integer, intent(IN) :: idir + type(scalar_field), dimension(sys_size), intent(INOUT) :: rhs_vf + type(scalar_field), intent(IN) :: divu + real(kind(0d0)), dimension(0:m, 0:n, 0:p), intent(INOUT) :: nbub + integer, intent(IN) :: t_step, id real(kind(0d0)), dimension(0:m, 0:n, 0:p), intent(INOUT) :: bub_adv_src - real(kind(0d0)), dimension(0:m, 0:n, 0:p, 1:nb), intent(INOUT) :: bub_r_src, & + real(kind(0d0)), dimension(0:m, 0:n, 0:p, 1:nb ), intent(INOUT) :: bub_r_src, & bub_v_src, & bub_p_src, & bub_m_src - real(kind(0d0)), dimension(0:m, 0:n, 0:p) :: nbub !< Bubble number density + !< Bubble number density real(kind(0d0)) :: tmp1, tmp2, tmp3, tmp4, & c_gas, c_liquid, & @@ -62,98 +97,182 @@ subroutine s_compute_bubble_source(idir, q_prim_vf, q_cons_vf, mydivu, & real(kind(0d0)) :: n_tait, B_tait real(kind(0d0)), dimension(nb) :: Rtmp, Vtmp - real(kind(0d0)) :: myR, myV, alf, myP, myRho, R2Vav + real(kind(0d0)) :: myR, myV, alf, myP, myRho, R2Vav, R3 + real(kind(0d0)), dimension(num_fluids) :: myalpha, myalpha_rho + real(kind(0d0)) :: start, finish real(kind(0d0)), dimension(2) :: Re !< Reynolds number - integer :: j, k, l, q, s !< Loop variables + integer :: i, j, k, l, q, ii !< Loop variables integer :: ndirs !< Number of coordinate directions - ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 - - if (idir == ndirs) then - bub_adv_src = 0.d0; bub_r_src = 0.d0; bub_v_src = 0.d0 - bub_p_src = 0.d0; bub_m_src = 0.d0 - - ! advection source - do j = 0, m; do k = 0, n; do l = 0, p - ! = 3 \alpha \bar{R^2 V} / \bar{R^3} = 4 pi nbub \bar{R^2 V} - do q = 1, nb - Rtmp(q) = q_prim_vf(bub_idx%rs(q))%sf(j, k, l) - Vtmp(q) = q_prim_vf(bub_idx%vs(q))%sf(j, k, l) + !$acc parallel loop collapse(3) gang vector default(present) private(Rtmp, Vtmp) + do l = 0, p + do k = 0, n + do j = 0, m + bub_adv_src(j, k, l) = 0d0 + +!$acc loop seq + do q = 1, nb + bub_r_src(j, k, l, q) = 0d0 + bub_v_src(j, k, l, q) = 0d0 + bub_p_src(j, k, l, q) = 0d0 + bub_m_src(j, k, l, q) = 0d0 + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) private(Rtmp, Vtmp) + do l = 0, p + do k = 0, n + do j = 0, m + +!$acc loop seq + do q = 1, nb + Rtmp(q) = q_prim_vf(rs(q))%sf(j, k, l) + Vtmp(q) = q_prim_vf(vs(q))%sf(j, k, l) + end do + + R3 = 0d0 + + !$acc loop seq + do q = 1, nb + R3 = R3 + weight(q)*Rtmp(q)**3.d0 + end do + + nbub(j, k, l) = (3.d0/(4.d0*pi))*q_prim_vf(alf_idx)%sf(j, k, l)/R3 + + R2Vav = 0d0 + + !$acc loop seq + do q = 1, nb + R2Vav = R2Vav + weight(q)*Rtmp(q)**2.d0*Vtmp(q) + end do + + bub_adv_src(j, k, l) = 4.d0*pi*nbub(j, k, l)*R2Vav + + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) private(myalpha_rho, myalpha) + do l = 0, p + do k = 0, n + do j = 0, m + !$acc loop seq + do q = 1, nb + + bub_r_src(j, k, l, q) = q_cons_vf(vs(q))%sf(j, k, l) + + !$acc loop seq + do ii = 1, num_fluids + myalpha_rho(ii) = q_cons_vf(ii)%sf(j, k, l) + myalpha(ii) = q_cons_vf(advxb + ii - 1)%sf(j, k, l) end do - ! Computes n_bub number bubble density - call s_comp_n_from_prim(q_prim_vf(alf_idx)%sf(j, k, l), & - Rtmp, nbub(j, k, l)) - - call s_quad((Rtmp**2.d0)*Vtmp, R2Vav) - bub_adv_src(j, k, l) = 4.d0*pi*nbub(j, k, l)*R2Vav - end do; end do; end do - - ! bubble radius and radial velocity source - do q = 1, nb; do j = 0, m; do k = 0, n; do l = 0, p - bub_r_src(j, k, l, q) = q_cons_vf(bub_idx%vs(q))%sf(j, k, l) - - call s_convert_to_mixture_variables(q_cons_vf, myRho, n_tait, B_tait, Re, j, k, l) - - n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' - - myRho = q_prim_vf(1)%sf(j, k, l) - myP = q_prim_vf(E_idx)%sf(j, k, l) - alf = q_prim_vf(alf_idx)%sf(j, k, l) - myR = q_prim_vf(bub_idx%rs(q))%sf(j, k, l) - myV = q_prim_vf(bub_idx%vs(q))%sf(j, k, l) - + myRho = 0d0 + n_tait = 0d0 + B_tait = 0d0 + + if (mpp_lim .and. (num_fluids > 2)) then + !$acc loop seq + do ii = 1, num_fluids + myRho = myRho + myalpha_rho(ii) + n_tait = n_tait + myalpha(ii)*gammas(ii) + B_tait = B_tait + myalpha(ii)*pi_infs(ii) + end do + else if (num_fluids > 2) then + !$acc loop seq + do ii = 1, num_fluids - 1 + myRho = myRho + myalpha_rho(ii) + n_tait = n_tait + myalpha(ii)*gammas(ii) + B_tait = B_tait + myalpha(ii)*pi_infs(ii) + end do + else + myRho = myalpha_rho(1) + n_tait = gammas(1) + B_tait = pi_infs(1) + end if + + n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' + + myRho = q_prim_vf(1)%sf(j, k, l) + myP = q_prim_vf(E_idx)%sf(j, k, l) + alf = q_prim_vf(alf_idx)%sf(j, k, l) + myR = q_prim_vf(rs(q))%sf(j, k, l) + myV = q_prim_vf(vs(q))%sf(j, k, l) + + if (.not. polytropic) then + pb = q_prim_vf(ps(q))%sf(j, k, l) + mv = q_prim_vf(ms(q))%sf(j, k, l) + call s_bwproperty(pb, q) + vflux = f_vflux(myR, myV, mv, q) + pbdot = f_bpres_dot(vflux, myR, myV, pb, mv, q) + + bub_p_src(j, k, l, q) = nbub(j, k, l)*pbdot + bub_m_src(j, k, l, q) = nbub(j, k, l)*vflux*4.d0*pi*(myR**2.d0) + else + pb = 0d0; mv = 0d0; vflux = 0d0; pbdot = 0d0 + end if + + if (bubble_model == 1) then + ! Gilmore bubbles + Cpinf = myP - pref + Cpbw = f_cpbw(R0(q), myR, myV, pb) + myH = f_H(Cpbw, Cpinf, n_tait, B_tait) + c_gas = f_cgas(Cpinf, n_tait, B_tait, myH) + Cpinf_dot = f_cpinfdot(myRho, myP, alf, n_tait, B_tait, bub_adv_src(j, k, l), divu%sf(j, k, l)) + myHdot = f_Hdot(Cpbw, Cpinf, Cpinf_dot, n_tait, B_tait, myR, myV, R0(q), pbdot) + rddot = f_rddot(Cpbw, myR, myV, myH, myHdot, c_gas, n_tait, B_tait) + else if (bubble_model == 2) then + ! Keller-Miksis bubbles + Cpinf = myP + Cpbw = f_cpbw_KM(R0(q), myR, myV, pb) + ! c_gas = dsqrt( n_tait*(Cpbw+B_tait) / myRho) + c_liquid = DSQRT(n_tait*(myP + B_tait)/(myRho*(1.d0 - alf))) + rddot = f_rddot_KM(pbdot, Cpinf, Cpbw, myRho, myR, myV, R0(q), c_liquid) + else if (bubble_model == 3) then + ! Rayleigh-Plesset bubbles + Cpbw = f_cpbw_KM(R0(q), myR, myV, pb) + rddot = f_rddot_RP(myP, myRho, myR, myV, R0(q), Cpbw) + end if + + bub_v_src(j, k, l, q) = nbub(j, k, l)*rddot + + if (alf < 1.d-11) then + bub_adv_src(j, k, l) = 0d0 + bub_r_src(j, k, l, q) = 0d0 + bub_v_src(j, k, l, q) = 0d0 if (.not. polytropic) then - pb = q_prim_vf(bub_idx%ps(q))%sf(j, k, l) - mv = q_prim_vf(bub_idx%ms(q))%sf(j, k, l) - call s_bwproperty(pb, q) - vflux = f_vflux(myR, myV, mv, q) - pbdot = f_bpres_dot(vflux, myR, myV, pb, mv, q) - - bub_p_src(j, k, l, q) = nbub(j, k, l)*pbdot - bub_m_src(j, k, l, q) = nbub(j, k, l)*vflux*4.d0*pi*(myR**2.d0) - else - pb = 0d0; mv = 0d0; vflux = 0d0; pbdot = 0d0 + bub_p_src(j, k, l, q) = 0d0 + bub_m_src(j, k, l, q) = 0d0 end if - - if (bubble_model == 1) then - ! Gilmore bubbles - Cpinf = myP - pref - Cpbw = f_cpbw(R0(q), myR, myV, pb) - myH = f_H(Cpbw, Cpinf, n_tait, B_tait) - c_gas = f_cgas(Cpinf, n_tait, B_tait, myH) - Cpinf_dot = f_cpinfdot(myRho, myP, alf, n_tait, B_tait, bub_adv_src(j, k, l), mydivu%sf(j, k, l)) - myHdot = f_Hdot(Cpbw, Cpinf, Cpinf_dot, n_tait, B_tait, myR, myV, R0(q), pbdot) - rddot = f_rddot(Cpbw, myR, myV, myH, myHdot, c_gas, n_tait, B_tait) - else if (bubble_model == 2) then - ! Keller-Miksis bubbles - Cpinf = myP - Cpbw = f_cpbw_KM(R0(q), myR, myV, pb) - ! c_gas = dsqrt( n_tait*(Cpbw+B_tait) / myRho) - c_liquid = DSQRT(n_tait*(myP + B_tait)/(myRho*(1.d0 - alf))) - rddot = f_rddot_KM(pbdot, Cpinf, Cpbw, myRho, myR, myV, R0(q), c_liquid) - else if (bubble_model == 3) then - ! Rayleigh-Plesset bubbles - Cpbw = f_cpbw_KM(R0(q), myR, myV, pb) - rddot = f_rddot_RP(myP, myRho, myR, myV, R0(q), Cpbw) - end if - - bub_v_src(j, k, l, q) = nbub(j, k, l)*rddot - - if (alf < 1.d-11) then - bub_adv_src(j, k, l) = 0d0 - bub_r_src(j, k, l, q) = 0d0 - bub_v_src(j, k, l, q) = 0d0 - if (.not. polytropic) then - bub_p_src(j, k, l, q) = 0d0 - bub_m_src(j, k, l, q) = 0d0 - end if - end if - - end do; end do; end do; end do - end if + end if + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = 0, p + do q = 0, n + do i = 0, m + rhs_vf(alf_idx)%sf(i, q, l) = rhs_vf(alf_idx)%sf(i, q, l) + bub_adv_src(i, q, l) + if (num_fluids > 1) rhs_vf(advxb)%sf(i, q, l) = & + rhs_vf(advxb)%sf(i, q, l) - bub_adv_src(i, q, l) + !$acc loop seq + do k = 1, nb + rhs_vf(rs(k))%sf(i, q, l) = rhs_vf(rs(k))%sf(i, q, l) + bub_r_src(i, q, l, k) + rhs_vf(vs(k))%sf(i, q, l) = rhs_vf(vs(k))%sf(i, q, l) + bub_v_src(i, q, l, k) + if (polytropic .neqv. .true.) then + rhs_vf(ps(k))%sf(i, q, l) = rhs_vf(ps(k))%sf(i, q, l) + bub_p_src(i, q, l, k) + rhs_vf(ms(k))%sf(i, q, l) = rhs_vf(ms(k))%sf(i, q, l) + bub_m_src(i, q, l, k) + end if + end do + end do + end do + end do end subroutine s_compute_bubble_source diff --git a/src/simulation/m_cbc.f90 b/src/simulation/m_cbc.fpp similarity index 62% rename from src/simulation/m_cbc.f90 rename to src/simulation/m_cbc.fpp index 4955bfb6b1..3ee00472f2 100644 --- a/src/simulation/m_cbc.f90 +++ b/src/simulation/m_cbc.fpp @@ -132,14 +132,12 @@ end subroutine s_compute_abstract_L integer :: dj - integer :: momxb, momxe, advxb, advxe, contxb, contxe, bubxb, bubxe integer :: bcxb, bcxe, bcyb, bcye, bczb, bcze - real(kind(0d0)), allocatable, dimension(:) :: gammas, pi_infs !$acc declare create(q_prim_rsx_vf, q_prim_rsy_vf, q_prim_rsz_vf, F_rsx_vf, F_src_rsx_vf,flux_rsx_vf, flux_src_rsx_vf, & !$acc F_rsy_vf, F_src_rsy_vf,flux_rsy_vf, flux_src_rsy_vf, F_rsz_vf, F_src_rsz_vf,flux_rsz_vf, flux_src_rsz_vf,alpha_rho,vel,adv,mf,Re, & !$acc dalpha_rho_ds,dvel_ds,dadv_ds,lambda,L,ds,fd_coef_x,fd_coef_y,fd_coef_z, & -!$acc pi_coef_x,pi_coef_y,pi_coef_z, momxb, momxe, advxb, advxe, contxb, contxe, bubxb, bubxe, gammas, pi_infs, bcxb, bcxe, bcyb, bcye, bczb, bcze, is1, is2, is3, dj) +!$acc pi_coef_x,pi_coef_y,pi_coef_z, bcxb, bcxe, bcyb, bcye, bczb, bcze, is1, is2, is3, dj) contains @@ -312,14 +310,6 @@ subroutine s_initialize_cbc_module() ! --------------------------------- ! Allocating the cell-width distribution in the s-direction allocate (ds(0:buff_size)) - allocate (gammas(1:num_fluids), pi_infs(1:num_fluids)) - - do i = 1, num_fluids - gammas(i) = fluid_pp(i)%gamma - pi_infs(i) = fluid_pp(i)%pi_inf - end do - - !$acc update device(gammas, pi_infs) ! Allocating/Computing CBC Coefficients in x-direction ============= if (all((/bc_x%beg, bc_x%end/) <= -5)) then @@ -439,17 +429,6 @@ subroutine s_initialize_cbc_module() ! --------------------------------- ! Associating the procedural pointer to the appropriate subroutine ! that will be utilized in the conversion to the mixture variables - momxb = mom_idx%beg - momxe = mom_idx%end - advxb = adv_idx%beg - advxe = adv_idx%end - contxb = cont_idx%beg - contxe = cont_idx%end - bubxb = bub_idx%beg - bubxe = bub_idx%end - - !$acc update device(momxb, momxe, advxb, advxe, contxb, contxe, bubxb, bubxe) - bcxb = bc_x%beg bcxe = bc_x%end @@ -496,208 +475,77 @@ subroutine s_compute_cbc_coefficients(cbc_dir, cbc_loc) ! -------------- end do ! Computing CBC1 Coefficients ====================================== - if (cbc_dir == 1) then - if (weno_order == 1) then - - fd_coef_x(:, cbc_loc) = 0d0 - fd_coef_x(0, cbc_loc) = -2d0/(ds(0) + ds(1)) - fd_coef_x(1, cbc_loc) = -fd_coef_x(0, cbc_loc) - - ! ================================================================== - - ! Computing CBC2 Coefficients ====================================== - elseif (weno_order == 3) then - - fd_coef_x(:, cbc_loc) = 0d0 - fd_coef_x(0, cbc_loc) = -6d0/(3d0*ds(0) + 2d0*ds(1) - ds(2)) - fd_coef_x(1, cbc_loc) = -4d0*fd_coef_x(0, cbc_loc)/3d0 - fd_coef_x(2, cbc_loc) = fd_coef_x(0, cbc_loc)/3d0 - - pi_coef_x(0, 0, cbc_loc) = (s_cb(0) - s_cb(1))/(s_cb(0) - s_cb(2)) - - ! ================================================================== - - ! Computing CBC4 Coefficients ====================================== - else - - fd_coef_x(:, cbc_loc) = 0d0 - fd_coef_x(0, cbc_loc) = -50d0/(25d0*ds(0) + 2d0*ds(1) & - - 1d1*ds(2) + 1d1*ds(3) & - - 3d0*ds(4)) - fd_coef_x(1, cbc_loc) = -48d0*fd_coef_x(0, cbc_loc)/25d0 - fd_coef_x(2, cbc_loc) = 36d0*fd_coef_x(0, cbc_loc)/25d0 - fd_coef_x(3, cbc_loc) = -16d0*fd_coef_x(0, cbc_loc)/25d0 - fd_coef_x(4, cbc_loc) = 3d0*fd_coef_x(0, cbc_loc)/25d0 - - pi_coef_x(0, 0, cbc_loc) = & - ((s_cb(0) - s_cb(1))*(s_cb(1) - s_cb(2))* & - (s_cb(1) - s_cb(3)))/((s_cb(1) - s_cb(4))* & - (s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(2))) - pi_coef_x(0, 1, cbc_loc) = & - ((s_cb(1) - s_cb(0))*(s_cb(1) - s_cb(2))* & - ((s_cb(1) - s_cb(3))*(s_cb(1) - s_cb(3)) - & - (s_cb(0) - s_cb(4))*((s_cb(3) - s_cb(1)) + & - (s_cb(4) - s_cb(1)))))/ & - ((s_cb(0) - s_cb(3))*(s_cb(1) - s_cb(3))* & - (s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) - pi_coef_x(0, 2, cbc_loc) = & - (s_cb(1) - s_cb(0))*((s_cb(1) - s_cb(2))* & - (s_cb(1) - s_cb(3)) + ((s_cb(0) - s_cb(2)) + & - (s_cb(1) - s_cb(3)))*(s_cb(0) - s_cb(4)))/ & - ((s_cb(2) - s_cb(0))*(s_cb(0) - s_cb(3))* & - (s_cb(0) - s_cb(4))) - pi_coef_x(1, 0, cbc_loc) = & - ((s_cb(0) - s_cb(2))*(s_cb(2) - s_cb(1))* & - (s_cb(2) - s_cb(3)))/((s_cb(2) - s_cb(4))* & - (s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(1))) - pi_coef_x(1, 1, cbc_loc) = & - ((s_cb(0) - s_cb(2))*(s_cb(1) - s_cb(2))* & - ((s_cb(1) - s_cb(3))*(s_cb(2) - s_cb(3)) + & - (s_cb(0) - s_cb(4))*((s_cb(1) - s_cb(3)) + & - (s_cb(2) - s_cb(4)))))/ & - ((s_cb(0) - s_cb(3))*(s_cb(1) - s_cb(3))* & - (s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) - pi_coef_x(1, 2, cbc_loc) = & - ((s_cb(1) - s_cb(2))*(s_cb(2) - s_cb(3))* & - (s_cb(2) - s_cb(4)))/((s_cb(0) - s_cb(2))* & - (s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) - - end if - elseif (cbc_dir == 2) then - if (weno_order == 1) then - - fd_coef_y(:, cbc_loc) = 0d0 - fd_coef_y(0, cbc_loc) = -2d0/(ds(0) + ds(1)) - fd_coef_y(1, cbc_loc) = -fd_coef_y(0, cbc_loc) - - ! ================================================================== - - ! Computing CBC2 Coefficients ====================================== - elseif (weno_order == 3) then - - fd_coef_y(:, cbc_loc) = 0d0 - fd_coef_y(0, cbc_loc) = -6d0/(3d0*ds(0) + 2d0*ds(1) - ds(2)) - fd_coef_y(1, cbc_loc) = -4d0*fd_coef_y(0, cbc_loc)/3d0 - fd_coef_y(2, cbc_loc) = fd_coef_y(0, cbc_loc)/3d0 - - pi_coef_y(0, 0, cbc_loc) = (s_cb(0) - s_cb(1))/(s_cb(0) - s_cb(2)) - - ! ================================================================== - - ! Computing CBC4 Coefficients ====================================== - else - - fd_coef_y(:, cbc_loc) = 0d0 - fd_coef_y(0, cbc_loc) = -50d0/(25d0*ds(0) + 2d0*ds(1) & - - 1d1*ds(2) + 1d1*ds(3) & - - 3d0*ds(4)) - fd_coef_y(1, cbc_loc) = -48d0*fd_coef_y(0, cbc_loc)/25d0 - fd_coef_y(2, cbc_loc) = 36d0*fd_coef_y(0, cbc_loc)/25d0 - fd_coef_y(3, cbc_loc) = -16d0*fd_coef_y(0, cbc_loc)/25d0 - fd_coef_y(4, cbc_loc) = 3d0*fd_coef_y(0, cbc_loc)/25d0 - - pi_coef_y(0, 0, cbc_loc) = & - ((s_cb(0) - s_cb(1))*(s_cb(1) - s_cb(2))* & - (s_cb(1) - s_cb(3)))/((s_cb(1) - s_cb(4))* & - (s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(2))) - pi_coef_y(0, 1, cbc_loc) = & - ((s_cb(1) - s_cb(0))*(s_cb(1) - s_cb(2))* & - ((s_cb(1) - s_cb(3))*(s_cb(1) - s_cb(3)) - & - (s_cb(0) - s_cb(4))*((s_cb(3) - s_cb(1)) + & - (s_cb(4) - s_cb(1)))))/ & - ((s_cb(0) - s_cb(3))*(s_cb(1) - s_cb(3))* & - (s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) - pi_coef_y(0, 2, cbc_loc) = & - (s_cb(1) - s_cb(0))*((s_cb(1) - s_cb(2))* & - (s_cb(1) - s_cb(3)) + ((s_cb(0) - s_cb(2)) + & - (s_cb(1) - s_cb(3)))*(s_cb(0) - s_cb(4)))/ & - ((s_cb(2) - s_cb(0))*(s_cb(0) - s_cb(3))* & - (s_cb(0) - s_cb(4))) - pi_coef_y(1, 0, cbc_loc) = & - ((s_cb(0) - s_cb(2))*(s_cb(2) - s_cb(1))* & - (s_cb(2) - s_cb(3)))/((s_cb(2) - s_cb(4))* & - (s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(1))) - pi_coef_y(1, 1, cbc_loc) = & - ((s_cb(0) - s_cb(2))*(s_cb(1) - s_cb(2))* & - ((s_cb(1) - s_cb(3))*(s_cb(2) - s_cb(3)) + & - (s_cb(0) - s_cb(4))*((s_cb(1) - s_cb(3)) + & - (s_cb(2) - s_cb(4)))))/ & - ((s_cb(0) - s_cb(3))*(s_cb(1) - s_cb(3))* & - (s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) - pi_coef_y(1, 2, cbc_loc) = & - ((s_cb(1) - s_cb(2))*(s_cb(2) - s_cb(3))* & - (s_cb(2) - s_cb(4)))/((s_cb(0) - s_cb(2))* & - (s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) - - end if - else + #:for CBC_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + if (cbc_dir == ${CBC_DIR}$) then if (weno_order == 1) then - fd_coef_z(:, cbc_loc) = 0d0 - fd_coef_z(0, cbc_loc) = -2d0/(ds(0) + ds(1)) - fd_coef_z(1, cbc_loc) = -fd_coef_z(0, cbc_loc) + fd_coef_${XYZ}$(:, cbc_loc) = 0d0 + fd_coef_${XYZ}$(0, cbc_loc) = -2d0/(ds(0) + ds(1)) + fd_coef_${XYZ}$(1, cbc_loc) = -fd_coef_${XYZ}$(0, cbc_loc) ! ================================================================== ! Computing CBC2 Coefficients ====================================== elseif (weno_order == 3) then - fd_coef_z(:, cbc_loc) = 0d0 - fd_coef_z(0, cbc_loc) = -6d0/(3d0*ds(0) + 2d0*ds(1) - ds(2)) - fd_coef_z(1, cbc_loc) = -4d0*fd_coef_z(0, cbc_loc)/3d0 - fd_coef_z(2, cbc_loc) = fd_coef_z(0, cbc_loc)/3d0 + fd_coef_${XYZ}$(:, cbc_loc) = 0d0 + fd_coef_${XYZ}$(0, cbc_loc) = -6d0/(3d0*ds(0) + 2d0*ds(1) - ds(2)) + fd_coef_${XYZ}$(1, cbc_loc) = -4d0*fd_coef_${XYZ}$(0, cbc_loc)/3d0 + fd_coef_${XYZ}$(2, cbc_loc) = fd_coef_${XYZ}$(0, cbc_loc)/3d0 - pi_coef_z(0, 0, cbc_loc) = (s_cb(0) - s_cb(1))/(s_cb(0) - s_cb(2)) + pi_coef_${XYZ}$(0, 0, cbc_loc) = (s_cb(0) - s_cb(1))/(s_cb(0) - s_cb(2)) ! ================================================================== ! Computing CBC4 Coefficients ====================================== else - fd_coef_z(:, cbc_loc) = 0d0 - fd_coef_z(0, cbc_loc) = -50d0/(25d0*ds(0) + 2d0*ds(1) & + fd_coef_${XYZ}$(:, cbc_loc) = 0d0 + fd_coef_${XYZ}$(0, cbc_loc) = -50d0/(25d0*ds(0) + 2d0*ds(1) & - 1d1*ds(2) + 1d1*ds(3) & - 3d0*ds(4)) - fd_coef_z(1, cbc_loc) = -48d0*fd_coef_z(0, cbc_loc)/25d0 - fd_coef_z(2, cbc_loc) = 36d0*fd_coef_z(0, cbc_loc)/25d0 - fd_coef_z(3, cbc_loc) = -16d0*fd_coef_z(0, cbc_loc)/25d0 - fd_coef_z(4, cbc_loc) = 3d0*fd_coef_z(0, cbc_loc)/25d0 + fd_coef_${XYZ}$(1, cbc_loc) = -48d0*fd_coef_${XYZ}$(0, cbc_loc)/25d0 + fd_coef_${XYZ}$(2, cbc_loc) = 36d0*fd_coef_${XYZ}$(0, cbc_loc)/25d0 + fd_coef_${XYZ}$(3, cbc_loc) = -16d0*fd_coef_${XYZ}$(0, cbc_loc)/25d0 + fd_coef_${XYZ}$(4, cbc_loc) = 3d0*fd_coef_${XYZ}$(0, cbc_loc)/25d0 - pi_coef_z(0, 0, cbc_loc) = & + pi_coef_${XYZ}$(0, 0, cbc_loc) = & ((s_cb(0) - s_cb(1))*(s_cb(1) - s_cb(2))* & (s_cb(1) - s_cb(3)))/((s_cb(1) - s_cb(4))* & (s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(2))) - pi_coef_z(0, 1, cbc_loc) = & + pi_coef_${XYZ}$(0, 1, cbc_loc) = & ((s_cb(1) - s_cb(0))*(s_cb(1) - s_cb(2))* & ((s_cb(1) - s_cb(3))*(s_cb(1) - s_cb(3)) - & (s_cb(0) - s_cb(4))*((s_cb(3) - s_cb(1)) + & (s_cb(4) - s_cb(1)))))/ & ((s_cb(0) - s_cb(3))*(s_cb(1) - s_cb(3))* & (s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) - pi_coef_z(0, 2, cbc_loc) = & + pi_coef_${XYZ}$(0, 2, cbc_loc) = & (s_cb(1) - s_cb(0))*((s_cb(1) - s_cb(2))* & (s_cb(1) - s_cb(3)) + ((s_cb(0) - s_cb(2)) + & (s_cb(1) - s_cb(3)))*(s_cb(0) - s_cb(4)))/ & ((s_cb(2) - s_cb(0))*(s_cb(0) - s_cb(3))* & (s_cb(0) - s_cb(4))) - pi_coef_z(1, 0, cbc_loc) = & + pi_coef_${XYZ}$(1, 0, cbc_loc) = & ((s_cb(0) - s_cb(2))*(s_cb(2) - s_cb(1))* & (s_cb(2) - s_cb(3)))/((s_cb(2) - s_cb(4))* & (s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(1))) - pi_coef_z(1, 1, cbc_loc) = & + pi_coef_${XYZ}$(1, 1, cbc_loc) = & ((s_cb(0) - s_cb(2))*(s_cb(1) - s_cb(2))* & ((s_cb(1) - s_cb(3))*(s_cb(2) - s_cb(3)) + & (s_cb(0) - s_cb(4))*((s_cb(1) - s_cb(3)) + & (s_cb(2) - s_cb(4)))))/ & ((s_cb(0) - s_cb(3))*(s_cb(1) - s_cb(3))* & (s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) - pi_coef_z(1, 2, cbc_loc) = & + pi_coef_${XYZ}$(1, 2, cbc_loc) = & ((s_cb(1) - s_cb(2))*(s_cb(2) - s_cb(3))* & (s_cb(2) - s_cb(4)))/((s_cb(0) - s_cb(2))* & (s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) end if end if + #:endfor + ! END: Computing CBC4 Coefficients ================================= ! Nullifying CBC coefficients @@ -843,24 +691,25 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- call s_associate_cbc_coefficients_pointers(cbc_dir, cbc_loc) - if (cbc_dir == 1) then + #:for CBC_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + if (cbc_dir == ${CBC_DIR}$) then ! PI2 of flux_rs_vf and flux_src_rs_vf at j = 1/2 ================== if (weno_order == 3) then - call s_convert_primitive_to_flux_variables(q_prim_rsx_vf, & - F_rsx_vf, & - F_src_rsx_vf, & + call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, & + F_rs${XYZ}$_vf, & + F_src_rs${XYZ}$_vf, & is1, is2, is3, starty, startz) !$acc parallel loop collapse(3) gang vector default(present) do i = 1, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end - flux_rsx_vf(0, k, r, i) = F_rsx_vf(0, k, r, i) & - + pi_coef_x(0, 0, cbc_loc)* & - (F_rsx_vf(1, k, r, i) - & - F_rsx_vf(0, k, r, i)) + flux_rs${XYZ}$_vf(0, k, r, i) = F_rs${XYZ}$_vf(0, k, r, i) & + + pi_coef_${XYZ}$(0, 0, cbc_loc)* & + (F_rs${XYZ}$_vf(1, k, r, i) - & + F_rs${XYZ}$_vf(0, k, r, i)) end do end do end do @@ -869,10 +718,10 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end - flux_src_rsx_vf(0, k, r, i) = F_src_rsx_vf(0, k, r, i) + & - (F_src_rsx_vf(1, k, r, i) - & - F_src_rsx_vf(0, k, r, i)) & - *pi_coef_x(0, 0, cbc_loc) + flux_src_rs${XYZ}$_vf(0, k, r, i) = F_src_rs${XYZ}$_vf(0, k, r, i) + & + (F_src_rs${XYZ}$_vf(1, k, r, i) - & + F_src_rs${XYZ}$_vf(0, k, r, i)) & + *pi_coef_${XYZ}$(0, 0, cbc_loc) end do end do end do @@ -881,9 +730,9 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- ! PI4 of flux_rs_vf and flux_src_rs_vf at j = 1/2, 3/2 ============= elseif (weno_order == 5) then - call s_convert_primitive_to_flux_variables(q_prim_rsx_vf, & - F_rsx_vf, & - F_src_rsx_vf, & + call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, & + F_rs${XYZ}$_vf, & + F_src_rs${XYZ}$_vf, & is1, is2, is3, starty, startz) !$acc parallel loop collapse(4) gang vector default(present) @@ -891,16 +740,16 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- do j = 0, 1 do r = is3%beg, is3%end do k = is2%beg, is2%end - flux_rsx_vf(j, k, r, i) = F_rsx_vf(j, k, r, i) & - + pi_coef_x(j, 0, cbc_loc)* & - (F_rsx_vf(3, k, r, i) - & - F_rsx_vf(2, k, r, i)) & - + pi_coef_x(j, 1, cbc_loc)* & - (F_rsx_vf(2, k, r, i) - & - F_rsx_vf(1, k, r, i)) & - + pi_coef_x(j, 2, cbc_loc)* & - (F_rsx_vf(1, k, r, i) - & - F_rsx_vf(0, k, r, i)) + flux_rs${XYZ}$_vf(j, k, r, i) = F_rs${XYZ}$_vf(j, k, r, i) & + + pi_coef_${XYZ}$(j, 0, cbc_loc)* & + (F_rs${XYZ}$_vf(3, k, r, i) - & + F_rs${XYZ}$_vf(2, k, r, i)) & + + pi_coef_${XYZ}$(j, 1, cbc_loc)* & + (F_rs${XYZ}$_vf(2, k, r, i) - & + F_rs${XYZ}$_vf(1, k, r, i)) & + + pi_coef_${XYZ}$(j, 2, cbc_loc)* & + (F_rs${XYZ}$_vf(1, k, r, i) - & + F_rs${XYZ}$_vf(0, k, r, i)) end do end do end do @@ -911,16 +760,16 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- do j = 0, 1 do r = is3%beg, is3%end do k = is2%beg, is2%end - flux_src_rsx_vf(j, k, r, i) = F_src_rsx_vf(j, k, r, i) + & - (F_src_rsx_vf(3, k, r, i) - & - F_src_rsx_vf(2, k, r, i)) & - *pi_coef_x(j, 0, cbc_loc) + & - (F_src_rsx_vf(2, k, r, i) - & - F_src_rsx_vf(1, k, r, i)) & - *pi_coef_x(j, 1, cbc_loc) + & - (F_src_rsx_vf(1, k, r, i) - & - F_src_rsx_vf(0, k, r, i)) & - *pi_coef_x(j, 2, cbc_loc) + flux_src_rs${XYZ}$_vf(j, k, r, i) = F_src_rs${XYZ}$_vf(j, k, r, i) + & + (F_src_rs${XYZ}$_vf(3, k, r, i) - & + F_src_rs${XYZ}$_vf(2, k, r, i)) & + *pi_coef_${XYZ}$(j, 0, cbc_loc) + & + (F_src_rs${XYZ}$_vf(2, k, r, i) - & + F_src_rs${XYZ}$_vf(1, k, r, i)) & + *pi_coef_${XYZ}$(j, 1, cbc_loc) + & + (F_src_rs${XYZ}$_vf(1, k, r, i) - & + F_src_rs${XYZ}$_vf(0, k, r, i)) & + *pi_coef_${XYZ}$(j, 2, cbc_loc) end do end do end do @@ -937,12 +786,12 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- ! Transferring the Primitive Variables ======================= !$acc loop seq do i = 1, contxe - alpha_rho(i) = q_prim_rsx_vf(0, k, r, i) + alpha_rho(i) = q_prim_rs${XYZ}$_vf(0, k, r, i) end do !$acc loop seq do i = 1, num_dims - vel(i) = q_prim_rsx_vf(0, k, r, contxe + i) + vel(i) = q_prim_rs${XYZ}$_vf(0, k, r, contxe + i) end do vel_K_sum = 0d0 @@ -951,11 +800,11 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- vel_K_sum = vel_K_sum + vel(i)**2d0 end do - pres = q_prim_rsx_vf(0, k, r, E_idx) + pres = q_prim_rs${XYZ}$_vf(0, k, r, E_idx) !$acc loop seq do i = 1, advxe - E_idx - adv(i) = q_prim_rsx_vf(0, k, r, E_idx + i) + adv(i) = q_prim_rs${XYZ}$_vf(0, k, r, E_idx + i) end do if (bubbles) then @@ -985,7 +834,7 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- c = 0d0 !$acc loop seq do i = 1, num_fluids - c = c + q_prim_rsx_vf(0, k, r, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & + c = c + q_prim_rs${XYZ}$_vf(0, k, r, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (pres + pi_infs(i)/(gammas(i) + 1d0)) end do c = c/rho @@ -1026,24 +875,24 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- !$acc loop seq do i = 1, contxe - dalpha_rho_ds(i) = q_prim_rsx_vf(j, k, r, i)* & - fd_coef_x(j, cbc_loc) + & + dalpha_rho_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, i)* & + fd_coef_${XYZ}$(j, cbc_loc) + & dalpha_rho_ds(i) end do !$acc loop seq do i = 1, num_dims - dvel_ds(i) = q_prim_rsx_vf(j, k, r, contxe + i)* & - fd_coef_x(j, cbc_loc) + & + dvel_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, contxe + i)* & + fd_coef_${XYZ}$(j, cbc_loc) + & dvel_ds(i) end do - dpres_ds = q_prim_rsx_vf(j, k, r, E_idx)* & - fd_coef_x(j, cbc_loc) + & + dpres_ds = q_prim_rs${XYZ}$_vf(j, k, r, E_idx)* & + fd_coef_${XYZ}$(j, cbc_loc) + & dpres_ds !$acc loop seq do i = 1, advxe - E_idx - dadv_ds(i) = q_prim_rsx_vf(j, k, r, E_idx + i)* & - fd_coef_x(j, cbc_loc) + & + dadv_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, E_idx + i)* & + fd_coef_${XYZ}$(j, cbc_loc) + & dadv_ds(i) end do end do @@ -1134,710 +983,18 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- ! flux_rs_vf and flux_src_rs_vf at j = -1/2 ================== !$acc loop seq do i = 1, contxe - flux_rsx_vf(-1, k, r, i) = flux_rsx_vf(0, k, r, i) & - + ds(0)*dalpha_rho_dt(i) - end do - - !$acc loop seq - do i = momxb, momxe - flux_rsx_vf(-1, k, r, i) = flux_rsx_vf(0, k, r, i) & - + ds(0)*(vel(i - contxe)*drho_dt & - + rho*dvel_dt(i - contxe)) - end do - - flux_rsx_vf(-1, k, r, E_idx) = flux_rsx_vf(0, k, r, E_idx) & - + ds(0)*(pres*dgamma_dt & - + gamma*dpres_dt & - + dpi_inf_dt & - + rho*vel_dv_dt_sum & - + 5d-1*drho_dt*vel_K_sum) - - if (riemann_solver == 1) then - !$acc loop seq - do i = advxb, advxe - flux_rsx_vf(-1, k, r, i) = 0d0 - end do - - !$acc loop seq - do i = advxb, advxe - flux_src_rsx_vf(-1, k, r, i) = & - 1d0/max(abs(vel(dir_idx(1))), sgm_eps) & - *sign(1d0, vel(dir_idx(1))) & - *(flux_rsx_vf(0, k, r, i) & - + vel(dir_idx(1)) & - *flux_src_rsx_vf(0, k, r, i) & - + ds(0)*dadv_dt(i - E_idx)) - end do - - else - - !$acc loop seq - do i = advxb, advxe - flux_rsx_vf(-1, k, r, i) = flux_rsx_vf(0, k, r, i) - & - adv(i - E_idx)*flux_src_rsx_vf(0, k, r, i) + & - ds(0)*dadv_dt(i - E_idx) - end do - - !$acc loop seq - do i = advxb, advxe - flux_src_rsx_vf(-1, k, r, i) = 0d0 - end do - - end if - ! END: flux_rs_vf and flux_src_rs_vf at j = -1/2 ============= - - end do - end do - - else if (cbc_dir == 2) then - ! PI2 of flux_rs_vf and flux_src_rs_vf at j = 1/2 ================== - if (weno_order == 3) then - - call s_convert_primitive_to_flux_variables(q_prim_rsy_vf, & - F_rsy_vf, & - F_src_rsy_vf, & - is1, is2, is3, startx, startz) - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, advxe - do r = is3%beg, is3%end - do k = is2%beg, is2%end - flux_rsy_vf(0, k, r, i) = F_rsy_vf(0, k, r, i) & - + pi_coef_y(0, 0, cbc_loc)* & - (F_rsy_vf(1, k, r, i) - & - F_rsy_vf(0, k, r, i)) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = advxb, advxe - do r = is3%beg, is3%end - do k = is2%beg, is2%end - flux_src_rsy_vf(0, k, r, i) = F_src_rsy_vf(0, k, r, i) + & - (F_src_rsy_vf(1, k, r, i) - & - F_src_rsy_vf(0, k, r, i)) & - *pi_coef_y(0, 0, cbc_loc) - end do - end do - end do - ! ================================================================== - - ! PI4 of flux_rs_vf and flux_src_rs_vf at j = 1/2, 3/2 ============= - elseif (weno_order == 5) then - - call s_convert_primitive_to_flux_variables(q_prim_rsy_vf, & - F_rsy_vf, & - F_src_rsy_vf, & - is1, is2, is3, startx, startz) - - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, advxe - do j = 0, 1 - do r = is3%beg, is3%end - do k = is2%beg, is2%end - flux_rsy_vf(j, k, r, i) = F_rsy_vf(j, k, r, i) & - + pi_coef_y(j, 0, cbc_loc)* & - (F_rsy_vf(3, k, r, i) - & - F_rsy_vf(2, k, r, i)) & - + pi_coef_y(j, 1, cbc_loc)* & - (F_rsy_vf(2, k, r, i) - & - F_rsy_vf(1, k, r, i)) & - + pi_coef_y(j, 2, cbc_loc)* & - (F_rsy_vf(1, k, r, i) - & - F_rsy_vf(0, k, r, i)) - end do - end do - end do - end do - - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb, advxe - do j = 0, 1 - do r = is3%beg, is3%end - do k = is2%beg, is2%end - flux_src_rsy_vf(j, k, r, i) = F_src_rsy_vf(j, k, r, i) + & - (F_src_rsy_vf(3, k, r, i) - & - F_src_rsy_vf(2, k, r, i)) & - *pi_coef_y(j, 0, cbc_loc) + & - (F_src_rsy_vf(2, k, r, i) - & - F_src_rsy_vf(1, k, r, i)) & - *pi_coef_y(j, 1, cbc_loc) + & - (F_src_rsy_vf(1, k, r, i) - & - F_src_rsy_vf(0, k, r, i)) & - *pi_coef_y(j, 2, cbc_loc) - end do - end do - end do - end do - - end if - ! ================================================================== - - ! FD2 or FD4 of RHS at j = 0 ======================================= - !$acc parallel loop collapse(2) gang vector default(present) private(alpha_rho, vel, adv, mf, dvel_ds, dadv_ds, Re_cbc, dalpha_rho_ds,dvel_dt, dadv_dt, dalpha_rho_dt,L, lambda) - do r = is3%beg, is3%end - do k = is2%beg, is2%end - - ! Transferring the Primitive Variables ======================= - !$acc loop seq - do i = 1, contxe - alpha_rho(i) = q_prim_rsy_vf(0, k, r, i) - end do - - !$acc loop seq - do i = 1, num_dims - vel(i) = q_prim_rsy_vf(0, k, r, contxe + i) - end do - - vel_K_sum = 0d0 - !$acc loop seq - do i = 1, num_dims - vel_K_sum = vel_K_sum + vel(i)**2d0 - end do - - pres = q_prim_rsy_vf(0, k, r, E_idx) - - !$acc loop seq - do i = 1, advxe - E_idx - adv(i) = q_prim_rsy_vf(0, k, r, E_idx + i) - end do - - if (bubbles) then - call s_convert_species_to_mixture_variables_bubbles_acc(rho, gamma, pi_inf, adv, alpha_rho, 0, k, r) - - else - call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, adv, alpha_rho, Re_cbc, 0, k, r) - end if - - E = gamma*pres + pi_inf + 5d-1*rho*vel_K_sum - - H = (E + pres)/rho - - !$acc loop seq - do i = 1, contxe - mf(i) = alpha_rho(i)/rho - end do - - ! Compute mixture sound speed - if (alt_soundspeed) then - blkmod1 = ((gammas(1) + 1d0)*pres + & - pi_infs(1))/gammas(1) - blkmod2 = ((gammas(2) + 1d0)*pres + & - pi_infs(2))/gammas(2) - c = (1d0/(rho*(adv(1)/blkmod1 + adv(2)/blkmod2))) - elseif (model_eqns == 3) then - c = 0d0 - !$acc loop seq - do i = 1, num_fluids - c = c + q_prim_rsy_vf(0, k, r, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & - (pres + pi_infs(i)/(gammas(i) + 1d0)) - end do - c = c/rho - else - c = ((H - 5d-1*vel_K_sum)/gamma) - end if - - c = sqrt(c) - - ! IF (mixture_err .AND. c < 0d0) THEN - ! c = sgm_eps - ! ELSE - ! c = SQRT(c) - ! END IF - - ! ============================================================ - - ! First-Order Spatial Derivatives of Primitive Variables ===== - - !$acc loop seq - do i = 1, contxe - dalpha_rho_ds(i) = 0d0 - end do - - !$acc loop seq - do i = 1, num_dims - dvel_ds(i) = 0d0 - end do - - dpres_ds = 0d0 - !$acc loop seq - do i = 1, advxe - E_idx - dadv_ds(i) = 0d0 - end do - - !$acc loop seq - do j = 0, buff_size - - !$acc loop seq - do i = 1, contxe - dalpha_rho_ds(i) = q_prim_rsy_vf(j, k, r, i)* & - fd_coef_y(j, cbc_loc) + & - dalpha_rho_ds(i) - end do - !$acc loop seq - do i = 1, num_dims - dvel_ds(i) = q_prim_rsy_vf(j, k, r, contxe + i)* & - fd_coef_y(j, cbc_loc) + & - dvel_ds(i) - end do - - dpres_ds = q_prim_rsy_vf(j, k, r, E_idx)* & - fd_coef_y(j, cbc_loc) + & - dpres_ds - !$acc loop seq - do i = 1, advxe - E_idx - dadv_ds(i) = q_prim_rsy_vf(j, k, r, E_idx + i)* & - fd_coef_y(j, cbc_loc) + & - dadv_ds(i) - end do - - end do - ! ============================================================ - - ! First-Order Temporal Derivatives of Primitive Variables ==== - lambda(1) = vel(dir_idx(1)) - c - lambda(2) = vel(dir_idx(1)) - lambda(3) = vel(dir_idx(1)) + c - - ! call s_compute_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - - if ((cbc_loc == -1 .and. bcyb == -5) .or. (cbc_loc == 1 .and. bcye == -5)) then - call s_compute_slip_wall_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bcyb == -6) .or. (cbc_loc == 1 .and. bcye == -6)) then -call s_compute_nonreflecting_subsonic_buffer_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bcyb == -7) .or. (cbc_loc == 1 .and. bcye == -7)) then -call s_compute_nonreflecting_subsonic_inflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bcyb == -8) .or. (cbc_loc == 1 .and. bcye == -8)) then -call s_compute_nonreflecting_subsonic_outflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bcyb == -9) .or. (cbc_loc == 1 .and. bcye == -9)) then -call s_compute_force_free_subsonic_outflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bcyb == -10) .or. (cbc_loc == 1 .and. bcye == -10)) then -call s_compute_constant_pressure_subsonic_outflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bcyb == -11) .or. (cbc_loc == 1 .and. bcye == -11)) then - call s_compute_supersonic_inflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else - call s_compute_supersonic_outflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - end if - - ! Be careful about the cylindrical coordinate! - if (cyl_coord .and. cbc_dir == 2 .and. cbc_loc == 1) then - dpres_dt = -5d-1*(L(advxe) + L(1)) + rho*c*c*vel(dir_idx(1)) & - /y_cc(n) - else - dpres_dt = -5d-1*(L(advxe) + L(1)) - end if - - !$acc loop seq - do i = 1, contxe - dalpha_rho_dt(i) = & - -(L(i + 1) - mf(i)*dpres_dt)/(c*c) - end do - - !$acc loop seq - do i = 1, num_dims - dvel_dt(dir_idx(i)) = dir_flg(dir_idx(i))* & - (L(1) - L(advxe))/(2d0*rho*c) + & - (dir_flg(dir_idx(i)) - 1d0)* & - L(momxb + i) - end do - - vel_dv_dt_sum = 0d0 - !$acc loop seq - do i = 1, num_dims - vel_dv_dt_sum = vel_dv_dt_sum + vel(i)*dvel_dt(i) - end do - - ! The treatment of void fraction source is unclear - if (cyl_coord .and. cbc_dir == 2 .and. cbc_loc == 1) then - !$acc loop seq - do i = 1, advxe - E_idx - dadv_dt(i) = -L(momxe + i) !+ adv(i) * vel(dir_idx(1))/y_cc(n) - end do - else - !$acc loop seq - do i = 1, advxe - E_idx - dadv_dt(i) = -L(momxe + i) - end do - end if - - drho_dt = 0d0; dgamma_dt = 0d0; dpi_inf_dt = 0d0 - - if (model_eqns == 1) then - drho_dt = dalpha_rho_dt(1) - dgamma_dt = dadv_dt(1) - dpi_inf_dt = dadv_dt(2) - else - !$acc loop seq - do i = 1, num_fluids - drho_dt = drho_dt + dalpha_rho_dt(i) - dgamma_dt = dgamma_dt + dadv_dt(i)*gammas(i) - dpi_inf_dt = dpi_inf_dt + dadv_dt(i)*pi_infs(i) - end do - end if - ! ============================================================ - - ! flux_rs_vf and flux_src_rs_vf at j = -1/2 ================== - !$acc loop seq - do i = 1, contxe - flux_rsy_vf(-1, k, r, i) = flux_rsy_vf(0, k, r, i) & - + ds(0)*dalpha_rho_dt(i) - end do - - !$acc loop seq - do i = momxb, momxe - flux_rsy_vf(-1, k, r, i) = flux_rsy_vf(0, k, r, i) & - + ds(0)*(vel(i - contxe)*drho_dt & - + rho*dvel_dt(i - contxe)) - end do - - flux_rsy_vf(-1, k, r, E_idx) = flux_rsy_vf(0, k, r, E_idx) & - + ds(0)*(pres*dgamma_dt & - + gamma*dpres_dt & - + dpi_inf_dt & - + rho*vel_dv_dt_sum & - + 5d-1*drho_dt*vel_K_sum) - - if (riemann_solver == 1) then - !$acc loop seq - do i = advxb, advxe - flux_rsy_vf(-1, k, r, i) = 0d0 - end do - - !$acc loop seq - do i = advxb, advxe - flux_src_rsy_vf(-1, k, r, i) = & - 1d0/max(abs(vel(dir_idx(1))), sgm_eps) & - *sign(1d0, vel(dir_idx(1))) & - *(flux_rsy_vf(0, k, r, i) & - + vel(dir_idx(1)) & - *flux_src_rsy_vf(0, k, r, i) & - + ds(0)*dadv_dt(i - E_idx)) - end do - - else - - !$acc loop seq - do i = advxb, advxe - flux_rsy_vf(-1, k, r, i) = flux_rsy_vf(0, k, r, i) - & - adv(i - E_idx)*flux_src_rsy_vf(0, k, r, i) + & - ds(0)*dadv_dt(i - E_idx) - end do - - !$acc loop seq - do i = advxb, advxe - flux_src_rsy_vf(-1, k, r, i) = 0d0 - end do - - end if - ! END: flux_rs_vf and flux_src_rs_vf at j = -1/2 ============= - - end do - end do - - else - ! PI2 of flux_rs_vf and flux_src_rs_vf at j = 1/2 ================== - if (weno_order == 3) then - - call s_convert_primitive_to_flux_variables(q_prim_rsz_vf, & - F_rsz_vf, & - F_src_rsz_vf, & - is1, is2, is3, starty, startx) - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, advxe - do r = is3%beg, is3%end - do k = is2%beg, is2%end - flux_rsz_vf(0, k, r, i) = F_rsz_vf(0, k, r, i) & - + pi_coef_z(0, 0, cbc_loc)* & - (F_rsz_vf(1, k, r, i) - & - F_rsz_vf(0, k, r, i)) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = advxb, advxe - do r = is3%beg, is3%end - do k = is2%beg, is2%end - flux_src_rsz_vf(0, k, r, i) = F_src_rsz_vf(0, k, r, i) + & - (F_src_rsz_vf(1, k, r, i) - & - F_src_rsz_vf(0, k, r, i)) & - *pi_coef_z(0, 0, cbc_loc) - end do - end do - end do - ! ================================================================== - - ! PI4 of flux_rs_vf and flux_src_rs_vf at j = 1/2, 3/2 ============= - elseif (weno_order == 5) then - - call s_convert_primitive_to_flux_variables(q_prim_rsz_vf, & - F_rsz_vf, & - F_src_rsz_vf, & - is1, is2, is3, starty, startx) - - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, advxe - do j = 0, 1 - do r = is3%beg, is3%end - do k = is2%beg, is2%end - flux_rsz_vf(j, k, r, i) = F_rsz_vf(j, k, r, i) & - + pi_coef_z(j, 0, cbc_loc)* & - (F_rsz_vf(3, k, r, i) - & - F_rsz_vf(2, k, r, i)) & - + pi_coef_z(j, 1, cbc_loc)* & - (F_rsz_vf(2, k, r, i) - & - F_rsz_vf(1, k, r, i)) & - + pi_coef_z(j, 2, cbc_loc)* & - (F_rsz_vf(1, k, r, i) - & - F_rsz_vf(0, k, r, i)) - end do - end do - end do - end do - - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb, advxe - do j = 0, 1 - do r = is3%beg, is3%end - do k = is2%beg, is2%end - flux_src_rsz_vf(j, k, r, i) = F_src_rsz_vf(j, k, r, i) + & - (F_src_rsz_vf(3, k, r, i) - & - F_src_rsz_vf(2, k, r, i)) & - *pi_coef_z(j, 0, cbc_loc) + & - (F_src_rsz_vf(2, k, r, i) - & - F_src_rsz_vf(1, k, r, i)) & - *pi_coef_z(j, 1, cbc_loc) + & - (F_src_rsz_vf(1, k, r, i) - & - F_src_rsz_vf(0, k, r, i)) & - *pi_coef_z(j, 2, cbc_loc) - end do - end do - end do - end do - - end if - ! ================================================================== - - ! FD2 or FD4 of RHS at j = 0 ======================================= - !$acc parallel loop collapse(2) gang vector default(present) private(alpha_rho, vel, adv, mf, dvel_ds, dadv_ds, Re_cbc, dalpha_rho_ds,dvel_dt, dadv_dt, dalpha_rho_dt,L, lambda) - do r = is3%beg, is3%end - do k = is2%beg, is2%end - - ! Transferring the Primitive Variables ======================= - !$acc loop seq - do i = 1, contxe - alpha_rho(i) = q_prim_rsz_vf(0, k, r, i) - end do - - !$acc loop seq - do i = 1, num_dims - vel(i) = q_prim_rsz_vf(0, k, r, contxe + i) - end do - - vel_K_sum = 0d0 - !$acc loop seq - do i = 1, num_dims - vel_K_sum = vel_K_sum + vel(i)**2d0 - end do - - pres = q_prim_rsz_vf(0, k, r, E_idx) - - !$acc loop seq - do i = 1, advxe - E_idx - adv(i) = q_prim_rsz_vf(0, k, r, E_idx + i) - end do - - if (bubbles) then - call s_convert_species_to_mixture_variables_bubbles_acc(rho, gamma, pi_inf, adv, alpha_rho, 0, k, r) - - else - call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, adv, alpha_rho, Re_cbc, 0, k, r) - end if - - E = gamma*pres + pi_inf + 5d-1*rho*vel_K_sum - - H = (E + pres)/rho - - !$acc loop seq - do i = 1, contxe - mf(i) = alpha_rho(i)/rho - end do - - ! Compute mixture sound speed - if (alt_soundspeed) then - blkmod1 = ((gammas(1) + 1d0)*pres + & - pi_infs(1))/gammas(1) - blkmod2 = ((gammas(2) + 1d0)*pres + & - pi_infs(2))/gammas(2) - c = (1d0/(rho*(adv(1)/blkmod1 + adv(2)/blkmod2))) - elseif (model_eqns == 3) then - c = 0d0 - !$acc loop seq - do i = 1, num_fluids - c = c + q_prim_rsz_vf(0, k, r, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & - (pres + pi_infs(i)/(gammas(i) + 1d0)) - end do - c = c/rho - else - c = ((H - 5d-1*vel_K_sum)/gamma) - end if - - c = sqrt(c) - - ! IF (mixture_err .AND. c < 0d0) THEN - ! c = sgm_eps - ! ELSE - ! c = SQRT(c) - ! END IF - - ! ============================================================ - - ! First-Order Spatial Derivatives of Primitive Variables ===== - - !$acc loop seq - do i = 1, contxe - dalpha_rho_ds(i) = 0d0 - end do - - !$acc loop seq - do i = 1, num_dims - dvel_ds(i) = 0d0 - end do - - dpres_ds = 0d0 - !$acc loop seq - do i = 1, advxe - E_idx - dadv_ds(i) = 0d0 - end do - - !$acc loop seq - do j = 0, buff_size - - !$acc loop seq - do i = 1, contxe - dalpha_rho_ds(i) = q_prim_rsz_vf(j, k, r, i)* & - fd_coef_z(j, cbc_loc) + & - dalpha_rho_ds(i) - end do - !$acc loop seq - do i = 1, num_dims - dvel_ds(i) = q_prim_rsz_vf(j, k, r, contxe + i)* & - fd_coef_z(j, cbc_loc) + & - dvel_ds(i) - end do - - dpres_ds = q_prim_rsz_vf(j, k, r, E_idx)* & - fd_coef_z(j, cbc_loc) + & - dpres_ds - !$acc loop seq - do i = 1, advxe - E_idx - dadv_ds(i) = q_prim_rsz_vf(j, k, r, E_idx + i)* & - fd_coef_z(j, cbc_loc) + & - dadv_ds(i) - end do - - end do - ! ============================================================ - - ! First-Order Temporal Derivatives of Primitive Variables ==== - lambda(1) = vel(dir_idx(1)) - c - lambda(2) = vel(dir_idx(1)) - lambda(3) = vel(dir_idx(1)) + c - - ! call s_compute_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - - if ((cbc_loc == -1 .and. bczb == -5) .or. (cbc_loc == 1 .and. bcze == -5)) then - call s_compute_slip_wall_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bczb == -6) .or. (cbc_loc == 1 .and. bcze == -6)) then -call s_compute_nonreflecting_subsonic_buffer_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bczb == -7) .or. (cbc_loc == 1 .and. bcze == -7)) then -call s_compute_nonreflecting_subsonic_inflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bczb == -8) .or. (cbc_loc == 1 .and. bcze == -8)) then -call s_compute_nonreflecting_subsonic_outflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bczb == -9) .or. (cbc_loc == 1 .and. bcze == -9)) then -call s_compute_force_free_subsonic_outflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bczb == -10) .or. (cbc_loc == 1 .and. bcze == -10)) then -call s_compute_constant_pressure_subsonic_outflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bczb == -11) .or. (cbc_loc == 1 .and. bcze == -11)) then - call s_compute_supersonic_inflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else - call s_compute_supersonic_outflow_L(dflt_int, lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - end if - - ! Be careful about the cylindrical coordinate! - if (cyl_coord .and. cbc_dir == 2 .and. cbc_loc == 1) then - dpres_dt = -5d-1*(L(advxe) + L(1)) + rho*c*c*vel(dir_idx(1)) & - /y_cc(n) - else - dpres_dt = -5d-1*(L(advxe) + L(1)) - end if - - !$acc loop seq - do i = 1, contxe - dalpha_rho_dt(i) = & - -(L(i + 1) - mf(i)*dpres_dt)/(c*c) - end do - - !$acc loop seq - do i = 1, num_dims - dvel_dt(dir_idx(i)) = dir_flg(dir_idx(i))* & - (L(1) - L(advxe))/(2d0*rho*c) + & - (dir_flg(dir_idx(i)) - 1d0)* & - L(momxb + i) - end do - - vel_dv_dt_sum = 0d0 - !$acc loop seq - do i = 1, num_dims - vel_dv_dt_sum = vel_dv_dt_sum + vel(i)*dvel_dt(i) - end do - - ! The treatment of void fraction source is unclear - if (cyl_coord .and. cbc_dir == 2 .and. cbc_loc == 1) then - !$acc loop seq - do i = 1, advxe - E_idx - dadv_dt(i) = -L(momxe + i) !+ adv(i) * vel(dir_idx(1))/y_cc(n) - end do - else - !$acc loop seq - do i = 1, advxe - E_idx - dadv_dt(i) = -L(momxe + i) - end do - end if - - drho_dt = 0d0; dgamma_dt = 0d0; dpi_inf_dt = 0d0 - - if (model_eqns == 1) then - drho_dt = dalpha_rho_dt(1) - dgamma_dt = dadv_dt(1) - dpi_inf_dt = dadv_dt(2) - else - !$acc loop seq - do i = 1, num_fluids - drho_dt = drho_dt + dalpha_rho_dt(i) - dgamma_dt = dgamma_dt + dadv_dt(i)*gammas(i) - dpi_inf_dt = dpi_inf_dt + dadv_dt(i)*pi_infs(i) - end do - end if - ! ============================================================ - - ! flux_rs_vf and flux_src_rs_vf at j = -1/2 ================== - !$acc loop seq - do i = 1, contxe - flux_rsz_vf(-1, k, r, i) = flux_rsz_vf(0, k, r, i) & + flux_rs${XYZ}$_vf(-1, k, r, i) = flux_rs${XYZ}$_vf(0, k, r, i) & + ds(0)*dalpha_rho_dt(i) end do !$acc loop seq do i = momxb, momxe - flux_rsz_vf(-1, k, r, i) = flux_rsz_vf(0, k, r, i) & + flux_rs${XYZ}$_vf(-1, k, r, i) = flux_rs${XYZ}$_vf(0, k, r, i) & + ds(0)*(vel(i - contxe)*drho_dt & + rho*dvel_dt(i - contxe)) end do - flux_rsz_vf(-1, k, r, E_idx) = flux_rsz_vf(0, k, r, E_idx) & + flux_rs${XYZ}$_vf(-1, k, r, E_idx) = flux_rs${XYZ}$_vf(0, k, r, E_idx) & + ds(0)*(pres*dgamma_dt & + gamma*dpres_dt & + dpi_inf_dt & @@ -1847,17 +1004,17 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- if (riemann_solver == 1) then !$acc loop seq do i = advxb, advxe - flux_rsz_vf(-1, k, r, i) = 0d0 + flux_rs${XYZ}$_vf(-1, k, r, i) = 0d0 end do !$acc loop seq do i = advxb, advxe - flux_src_rsz_vf(-1, k, r, i) = & + flux_src_rs${XYZ}$_vf(-1, k, r, i) = & 1d0/max(abs(vel(dir_idx(1))), sgm_eps) & *sign(1d0, vel(dir_idx(1))) & - *(flux_rsz_vf(0, k, r, i) & + *(flux_rs${XYZ}$_vf(0, k, r, i) & + vel(dir_idx(1)) & - *flux_src_rsz_vf(0, k, r, i) & + *flux_src_rs${XYZ}$_vf(0, k, r, i) & + ds(0)*dadv_dt(i - E_idx)) end do @@ -1865,14 +1022,14 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- !$acc loop seq do i = advxb, advxe - flux_rsz_vf(-1, k, r, i) = flux_rsz_vf(0, k, r, i) - & - adv(i - E_idx)*flux_src_rsz_vf(0, k, r, i) + & + flux_rs${XYZ}$_vf(-1, k, r, i) = flux_rs${XYZ}$_vf(0, k, r, i) - & + adv(i - E_idx)*flux_src_rs${XYZ}$_vf(0, k, r, i) + & ds(0)*dadv_dt(i - E_idx) end do !$acc loop seq do i = advxb, advxe - flux_src_rsz_vf(-1, k, r, i) = 0d0 + flux_src_rs${XYZ}$_vf(-1, k, r, i) = 0d0 end do end if @@ -1881,6 +1038,7 @@ subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & ! ----------------- end do end do end if + #:endfor ! END: FD2 or FD4 of RHS at j = 0 ================================== diff --git a/src/simulation/m_data_output.f90 b/src/simulation/m_data_output.f90 index f884234515..d174b9e114 100644 --- a/src/simulation/m_data_output.f90 +++ b/src/simulation/m_data_output.f90 @@ -95,13 +95,7 @@ end subroutine s_write_abstract_data_files ! ------------------- type(scalar_field), allocatable, dimension(:) :: grad_x_vf, grad_y_vf, grad_z_vf, norm_vf real(kind(0d0)), target, allocatable, dimension(:, :, :) :: energy - integer :: momxb, momxe - integer :: contxb, contxe - integer :: bubxb, bubxe - integer :: advxb, advxe - real(kind(0d0)), allocatable, dimension(:) :: gammas, pi_infs - !$acc declare create(momxb, momxe, contxb, contxe, bubxb, bubxe, advxb, advxe, gammas, pi_infs) - !> @} + procedure(s_write_abstract_data_files), pointer :: s_write_data_files => null() @@ -2456,20 +2450,6 @@ subroutine s_initialize_data_output_module() ! ------------------------- integer :: i !< Generic loop iterator - momxb = mom_idx%beg; momxe = mom_idx%end - bubxb = bub_idx%beg; bubxe = bub_idx%end - advxb = adv_idx%beg; advxe = adv_idx%end - contxb = cont_idx%beg; contxe = cont_idx%end -!$acc update device(momxb, momxe, bubxb, bubxe, advxb, advxe, contxb, contxe) - - allocate (gammas(1:num_fluids)) - allocate (pi_infs(1:num_fluids)) - - do i = 1, num_fluids - gammas(i) = fluid_pp(i)%gamma - pi_infs(i) = fluid_pp(i)%pi_inf - end do -!$acc update device(gammas, pi_infs) ! Allocating/initializing ICFL, VCFL, CCFL and Rc stability criteria allocate (icfl_sf(0:m, 0:n, 0:p)); icfl_max = 0d0 diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 31f0fd8ce8..a4e8589c90 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -301,6 +301,20 @@ module m_global_parameters !> @} !$acc declare create(monopole, mono, num_mono) + + + integer :: momxb, momxe + integer :: advxb, advxe + integer :: contxb, contxe + integer :: intxb, intxe + integer :: bubxb, bubxe + integer :: strxb, strxe + !$acc declare create(momxb, momxe, advxb, advxe, contxb, contxe, intxb, intxe, bubxb, bubxe, strxb, strxe) + + real(kind(0d0)), allocatable, dimension(:) :: gammas, pi_infs + !$acc declare create(gammas, pi_infs) + + real(kind(0d0)) :: mytime !< Current simulation time real(kind(0d0)) :: finaltime !< Final simulation time @@ -477,9 +491,10 @@ contains ! Determining the degree of the WENO polynomials weno_polyn = (weno_order - 1)/2 !$acc update device(weno_polyn) +!$acc update device(nb) #:endif -!$acc update device(nb) + ! Initializing the number of fluids for which viscous effects will ! be non-negligible, the number of distinctive material interfaces @@ -488,6 +503,7 @@ contains ! interfaces will be computed Re_size = 0 + ! Gamma/Pi_inf Model =============================================== if (model_eqns == 1) then @@ -786,6 +802,30 @@ contains grid_geometry = 3 end if + momxb = mom_idx%beg + momxe = mom_idx%end + advxb = adv_idx%beg + advxe = adv_idx%end + contxb = cont_idx%beg + contxe = cont_idx%end + bubxb = bub_idx%beg + bubxe = bub_idx%end + strxb = stress_idx%beg + strxe = stress_idx%end + intxb = internalEnergies_idx%beg + intxe = internalEnergies_idx%end + + +!$acc update device(momxb, momxe, advxb, advxe, contxb, contxe, bubxb, bubxe, intxb, intxe, sys_size, buff_size, E_idx, alf_idx, strxb, strxe) + + allocate (gammas(1:num_fluids), pi_infs(1:num_fluids)) + + do i = 1, num_fluids + gammas(i) = fluid_pp(i)%gamma + pi_infs(i) = fluid_pp(i)%pi_inf + end do +!$acc update device(gammas, pi_infs) + ! Allocating grid variables for the x-, y- and z-directions allocate (x_cb(-1 - buff_size:m + buff_size)) allocate (x_cc(-buff_size:m + buff_size)) @@ -799,6 +839,9 @@ contains allocate (z_cc(-buff_size:p + buff_size)) allocate (dz(-buff_size:p + buff_size)) + + + end subroutine s_initialize_global_parameters_module ! ----------------- !> Initializes non-polydisperse bubble modeling diff --git a/src/simulation/m_hypoelastic.f90 b/src/simulation/m_hypoelastic.f90 index ebc283f3d6..61cc26bf23 100644 --- a/src/simulation/m_hypoelastic.f90 +++ b/src/simulation/m_hypoelastic.f90 @@ -20,11 +20,9 @@ module m_hypoelastic private; public :: s_initialize_hypoelastic_module, & s_compute_hypoelastic_rhs - integer :: momxb, momxe - integer :: advxb, advxe - integer :: strxb, strxe + real(kind(0d0)), allocatable, dimension(:) :: Gs -!$acc declare create(momxb, momxe, advxb, advxe, strxb, strxe, Gs) +!$acc declare create( Gs) real(kind(0d0)), allocatable, dimension(:, :, :) :: du_dx, du_dy, du_dz @@ -56,13 +54,6 @@ subroutine s_initialize_hypoelastic_module() ! -------------------- end if !$acc enter data create(rho_K_field,G_K_field,du_dx) - momxb = mom_idx%beg - momxe = mom_idx%end - advxb = adv_idx%beg - advxe = adv_idx%end - strxb = stress_idx%beg - strxe = stress_idx%end -!$acc update device(momxb, momxe, advxb, advxe, strxb, strxe) do i = 1, num_fluids Gs(i) = fluid_pp(i)%G diff --git a/src/simulation/m_monopole.f90 b/src/simulation/m_monopole.f90 new file mode 100644 index 0000000000..7fcbb39737 --- /dev/null +++ b/src/simulation/m_monopole.f90 @@ -0,0 +1,445 @@ +!> +!! @file m_viscous.f90 +!! @brief Contains module m_viscous + +!> @brief The module contains the subroutines used to + +module m_monopole + + ! Dependencies ============================================================= + use m_derived_types !< Definitions of the derived types + + use m_global_parameters !< Definitions of the global parameters + + use m_bubbles !< Bubble dynamic routines + + use m_qbmm !< Moment inversion + + use m_variables_conversion !< State variables type conversion procedures + ! ========================================================================== + implicit none + private; public :: s_initialize_monopole_module, s_monopole_calculations + + integer, allocatable, dimension(:) :: pulse, support + !$acc declare create(pulse, support) + + real(kind(0d0)), allocatable, dimension(:, :) :: loc_mono + !$acc declare create(loc_mono) + + real(kind(0d0)), allocatable, dimension(:) :: foc_length, aperture + !$acc declare create(foc_length, aperture) + + real(kind(0d0)), allocatable, dimension(:) :: mag, length, npulse, dir, delay + !$acc declare create(mag, length, npulse, dir, delay) + + +contains + + subroutine s_initialize_monopole_module() + integer :: i, j !< generic loop variables + + allocate(mag(1:num_mono), support(1:num_mono), length(1:num_mono), npulse(1:num_mono), pulse(1:num_mono), dir(1:num_mono), delay(1:num_mono), loc_mono(1:3, 1:num_mono), foc_length(1:num_mono), aperture(1:num_mono)) + + do i = 1, num_mono + mag(i) = mono(i)%mag + support(i) = mono(i)%support + length(i) = mono(i)%length + npulse(i) = mono(i)%npulse + pulse(i) = mono(i)%pulse + dir(i) = mono(i)%dir + delay(i) = mono(i)%delay + foc_length(i) = mono(i)%foc_length + aperture(i) = mono(i)%aperture + do j = 1, 3 + loc_mono(j, i) = mono(i)%loc(j) + end do + end do + !$acc update device(mag, support, length, npulse, pulse, dir, delay, foc_length, aperture, loc_mono) + + + end subroutine + + subroutine s_monopole_calculations(mono_mass_src, mono_mom_src, mono_e_src, q_cons_vf, & + q_prim_vf, t_step, id, rhs_vf) + + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< + !! This variable contains the WENO-reconstructed values of the cell-average + !! conservative variables, which are located in q_cons_vf, at cell-interior + !! Gaussian quadrature points (QP). + + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< + !! The primitive variables at cell-interior Gaussian quadrature points. These + !! are calculated from the conservative variables and gradient magnitude (GM) + !! of the volume fractions, q_cons_qp and gm_alpha_qp, respectively. + + type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf + !> @name Monopole source terms + !> @{ + real(kind(0d0)), dimension(0:m, 0:n, 0:p), intent(inout) :: mono_mass_src, mono_e_src + real(kind(0d0)), dimension(1:num_dims, 0:m, 0:n, 0:p), intent(inout) :: mono_mom_src + !> @} + + integer, intent(IN) :: t_step, id + + real(kind(0d0)) :: myR, myV, alf, myP, myRho, R2Vav + + integer :: i, j, k, l, q, ii !< generic loop variables + integer :: term_index + + real(kind(0d0)), dimension(num_fluids) :: myalpha_rho, myalpha + + real(kind(0d0)) :: n_tait, B_tait, angle, angle_z + + + integer :: ndirs + + real(kind(0d0)) :: mytime, sound + real(kind(0d0)) :: s2, const_sos, s1 + + +!$acc parallel loop collapse(3) gang vector default(present) + do l = 0, p + do k = 0, n + do j = 0, m + mono_mass_src(j, k, l) = 0d0; mono_mom_src(1, j, k, l) = 0d0; mono_e_src(j, k, l) = 0d0; + if (n > 0) then + mono_mom_src(2, j, k, l) = 0d0 + end if + if (p > 0) then + mono_mom_src(3, j, k, l) = 0d0 + end if + end do + end do + end do + + +!$acc parallel loop collapse(3) gang vector default(present) private(myalpha_rho, myalpha) + do l = 0, p + do k = 0, n + do j = 0, m +!$acc loop seq + do q = 1, num_mono + + mytime = t_step*dt + if ((mytime >= delay(q)) .or. (delay(q) == dflt_real)) then +!$acc loop seq + do ii = 1, num_fluids + myalpha_rho(ii) = q_cons_vf(ii)%sf(j, k, l) + myalpha(ii) = q_cons_vf(advxb + ii - 1)%sf(j, k, l) + end do + + myRho = 0d0 + n_tait = 0d0 + B_tait = 0d0 + + if (bubbles) then + if (mpp_lim .and. (num_fluids > 2)) then + !$acc loop seq + do ii = 1, num_fluids + myRho = myRho + myalpha_rho(ii) + n_tait = n_tait + myalpha(ii)*gammas(ii) + B_tait = B_tait + myalpha(ii)*pi_infs(ii) + end do + else if (num_fluids > 2) then + !$acc loop seq + do ii = 1, num_fluids - 1 + myRho = myRho + myalpha_rho(ii) + n_tait = n_tait + myalpha(ii)*gammas(ii) + B_tait = B_tait + myalpha(ii)*pi_infs(ii) + end do + else + myRho = myalpha_rho(1) + n_tait = gammas(1) + B_tait = pi_infs(1) + end if + else + !$acc loop seq + do ii = 1, num_fluids + myRho = myRho + myalpha_rho(ii) + n_tait = n_tait + myalpha(ii)*gammas(ii) + B_tait = B_tait + myalpha(ii)*pi_infs(ii) + end do + end if + n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' + + sound = n_tait*(q_prim_vf(E_idx)%sf(j, k, l) + ((n_tait - 1d0)/n_tait)*B_tait)/myRho + sound = dsqrt(sound) +! const_sos = dsqrt(n_tait) + const_sos = n_tait*(1.01d5 + ((n_tait - 1d0)/n_tait)*B_tait)/myRho + const_sos = dsqrt(const_sos) + !TODO: does const_sos need to be changed? + + term_index = 2 + + angle = 0.d0 + angle_z = 0.d0 + + s2 = f_g(mytime, sound, const_sos, q, term_index)* & + f_delta(j, k, l, loc_mono(:, q), length(q), q, angle, angle_z) + !s2 = 1d0 + + if (support(q) == 5) then + term_index = 1 + s1 = f_g(mytime, sound, const_sos, q, term_index)* & + f_delta(j, k, l, loc_mono(:, q), length(q), q, angle, angle_z) + end if + + mono_mass_src(j, k, l) = mono_mass_src(j, k, l) + s2/sound +! mono_mass_src(j, k, l) = mono_mass_src(j, k, l) + s2/const_sos + + if (n == 0) then + + ! 1D + if (dir(q) < -0.1d0) then + !left-going wave + mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) - s2 + else + !right-going wave + mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2 + end if + else if (p == 0) then + ! IF ( (j==1) .AND. (k==1) .AND. proc_rank == 0) & + ! PRINT*, '====== Monopole magnitude: ', f_g(mytime,sound,const_sos,mono(q)) + if (dir(q) /= dflt_real) then + ! 2d + !mono_mom_src(1,j,k,l) = s2 + !mono_mom_src(2,j,k,l) = s2 + if (support(q) == 5) then + mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(angle) + mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(angle) + else + mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(dir(q)) + mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(dir(q)) + end if + end if + else + ! 3D + if (dir(q) /= dflt_real) then + if (support(q) == 5) then + mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(angle) + mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(angle) + else + mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(dir(q)) + mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(dir(q)) + end if + end if + end if + + if (model_eqns /= 4) then + if (support(q) == 5) then +! mono_E_src(j, k, l) = mono_E_src(j, k, l) + s1*sound**2.d0/(n_tait - 1.d0) + mono_E_src(j, k, l) = mono_E_src(j, k, l) + s1*const_sos**2.d0/(n_tait - 1.d0) + else + mono_E_src(j, k, l) = mono_E_src(j, k, l) + s2*sound/(n_tait - 1.d0) + end if + end if + + end if + end do + end do + end do + end do + +!$acc parallel loop collapse(3) gang vector default(present) + do l = 0, p + do k = 0, n + do j = 0, m +!$acc loop seq + do q = contxb, contxe + rhs_vf(q)%sf(j, k, l) = rhs_vf(q)%sf(j, k, l) + mono_mass_src(j, k, l) + end do +!$acc loop seq + do q = momxb, momxe + rhs_vf(q)%sf(j, k, l) = rhs_vf(q)%sf(j, k, l) + mono_mom_src(q - contxe, j, k, l) + end do + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + mono_e_src(j, k, l) + end do + end do + end do + + end subroutine + + !> This function gives the temporally varying amplitude of the pulse + !! @param mytime Simulation time + !! @param sos Sound speed + !! @param mysos Alternative speed of sound for testing + function f_g(mytime, sos, mysos, nm, term_index) +!$acc routine seq + real(kind(0d0)), intent(IN) :: mytime, sos, mysos + integer, intent(IN) :: nm + real(kind(0d0)) :: period, t0, sigt, pa + real(kind(0d0)) :: offset + real(kind(0d0)) :: f_g + integer :: term_index + + offset = 0d0 + if (delay(nm) /= dflt_real) offset = delay(nm) + + if (pulse(nm) == 1) then + ! Sine wave + period = length(nm)/sos + f_g = 0d0 + if (term_index == 1) then + f_g = mag(nm)*sin((mytime)*2.d0*pi/period)/mysos & + + mag(nm)/foc_length(nm)*(1.d0/(2.d0*pi/period)*cos((mytime)*2.d0*pi/period) & + - 1.d0/(2.d0*pi/period)) + elseif (mytime <= (npulse(nm)*period + offset)) then + f_g = mag(nm)*sin((mytime + offset)*2.d0*pi/period) + end if + else if (pulse(nm) == 2) then + ! Gaussian pulse + sigt = length(nm)/sos/7.d0 + t0 = 3.5d0*sigt + f_g = mag(nm)/(dsqrt(2.d0*pi)*sigt)* & + dexp(-0.5d0*((mytime - t0)**2.d0)/(sigt**2.d0)) + else if (pulse(nm) == 3) then + ! Square wave + sigt = length(nm)/sos + t0 = 0d0; f_g = 0d0 + if (mytime > t0 .and. mytime < sigt) then + f_g = mag(nm) + end if + else + end if + + end function f_g + + !> This function give the spatial support of the acoustic source + !! @param j First coordinate-direction location index + !! @param k Second coordinate-direction location index + !! @param l Third coordinate-direction location index + !! @param mono_loc Nominal source term location + !! @param mono_leng Length of source term in space + function f_delta(j, k, l, mono_loc, mono_leng, nm, angle, angle_z) +!$acc routine seq + real(kind(0d0)), dimension(3), intent(IN) :: mono_loc + integer, intent(IN) :: nm + real(kind(0d0)), intent(IN) :: mono_leng + integer, intent(in) :: j, k, l + + integer :: q + real(kind(0d0)) :: h, hx, hy, hz + real(kind(0d0)) :: hxnew, hynew + real(kind(0d0)) :: sig + real(kind(0d0)) :: f_delta + real(kind(0d0)) :: angle + real(kind(0d0)) :: angle_z + + if (n == 0) then + sig = dx(j) + sig = sig*2.5d0 + else if (p == 0) then + sig = maxval((/dx(j), dy(k)/)) + sig = sig*2.5d0 + else + sig = maxval((/dx(j), dy(k), dz(l)/)) + sig = sig*2.5d0 + end if + + if (n == 0) then !1D + if (support(nm) == 1) then + ! 1D delta function + hx = abs(mono_loc(1) - x_cc(j)) + + f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & + dexp(-0.5d0*(hx/(sig/2.d0))**2.d0) + else if (support(nm) == 0) then + ! Support for all x + f_delta = 1.d0 + end if + else if (p == 0) then !2D + hx = mono_loc(1) - x_cc(j) + hy = mono_loc(2) - y_cc(k) + if (support(nm) == 1) then + ! 2D delta function + sig = mono_leng/20.d0 + h = dsqrt(hx**2.d0 + hy**2.d0) + + f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & + dexp(-0.5d0*((h/(sig/2.d0))**2.d0)) + else if (support(nm) == 2) then + !only support for y \pm some value + if (abs(hy) < length(nm)) then + f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & + dexp(-0.5d0*(hx/(sig/2.d0))**2.d0) + else + f_delta = 0d0 + end if + else if (support(nm) == 3) then + ! Only support along some line + hx = x_cc(j) - mono_loc(1) + hy = y_cc(k) - mono_loc(2) + + ! Rotate actual point by -theta + hxnew = cos(dir(nm))*hx + sin(dir(nm))*hy + hynew = -1.d0*sin(dir(nm))*hx + cos(dir(nm))*hy + if (abs(hynew) < mono_loc(3)/2.d0) then + f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & + dexp(-0.5d0*(hxnew/(sig/2.d0))**2.d0) + else + f_delta = 0d0 + end if + else if (support(nm) == 4) then + ! Support for all y + f_delta = 1.d0/(dsqrt(2.d0*pi)*sig)* & + dexp(-0.5d0*(hx/sig)**2.d0) + else if (support(nm) == 5) then + ! Support along 'transducer' + hx = x_cc(j) - mono_loc(1) + hy = y_cc(k) - mono_loc(2) + + hxnew = foc_length(nm) - dsqrt(hy**2.d0 + (foc_length(nm) - hx)**2.d0) + if ((abs(hy) < aperture(nm)/2.d0) .and. (hx < foc_length(nm))) then + f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & + dexp(-0.5d0*(hxnew/(sig/2.d0))**2.d0) + angle = -atan(hy/(foc_length(nm) - hx)) + else + f_delta = 0d0 + end if + end if + else !3D + + hx = x_cc(j) - mono_loc(1) + hy = y_cc(k) - mono_loc(2) + hz = z_cc(l) - mono_loc(3) + if (support(nm) == 3) then + + ! Rotate actual point by -theta + hxnew = cos(dir(nm))*hx + sin(dir(nm))*hy + hynew = -1.d0*sin(dir(nm))*hx + cos(dir(nm))*hy + + if (abs(hynew) < length(nm)/2. .and. & + abs(hz) < length(nm)/2.) then + f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & + dexp(-0.5d0*(hxnew/(sig/2.d0))**2.d0) + else + f_delta = 0d0 + end if + else if (support(nm) == 4) then + ! Support for all x,y + f_delta = 1.d0/(dsqrt(2.d0*pi)*sig)* & + dexp(-0.5d0*(hz/sig)**2.d0) + else if (support(nm) == 5) then + ! Support along 'transducer' + hx = x_cc(j) - mono_loc(1) + hy = y_cc(k) - mono_loc(2) + hz = z_cc(l) - mono_loc(3) + + hxnew = foc_length(nm) - dsqrt(hy**2.d0 + hz**2.d0 + (foc_length(nm) - hx)**2.d0) + if ((dsqrt(hy**2.d0 + hz**2.d0) < aperture(nm)/2.d0) .and. & + (hx < foc_length(nm))) then + + f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & + dexp(-0.5d0*(hxnew/(sig/2.d0))**2.d0) + + angle = -atan(hy/(foc_length(nm) - hx)) + angle_z = -atan(hz/(foc_length(nm) - hx)) + else + f_delta = 0d0 + end if + end if + end if + + end function f_delta + +end module diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index f9b1d85789..584b6e5fdf 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -34,16 +34,11 @@ module m_qbmm type(int_bounds_info) :: is1, is2, is3 - integer :: momxb, momxe - integer :: contxb, contxe - integer :: bubxb, bubxe - integer :: advxb, advxe - real(kind(0d0)), allocatable, dimension(:) :: gammas, pi_infs integer, allocatable, dimension(:) :: bubrs integer, allocatable, dimension(:, :) :: bubmoms !$acc declare create(momrhs, nterms, is1, is2, is3) -!$acc declare create(momxb, momxe, bubxb, bubxe, contxb, contxe, advxb, advxe, gammas, pi_infs, bubrs, bubmoms) +!$acc declare create( bubrs, bubmoms) contains @@ -159,24 +154,11 @@ contains !$acc update device(momrhs) - momxb = mom_idx%beg; momxe = mom_idx%end - bubxb = bub_idx%beg; bubxe = bub_idx%end - advxb = adv_idx%beg; advxe = adv_idx%end - contxb = cont_idx%beg; contxe = cont_idx%end -!$acc update device(momxb, momxe, bubxb, bubxe, advxb, advxe, contxb, contxe) - - allocate (gammas(1:num_fluids)) - allocate (pi_infs(1:num_fluids)) - allocate (bubrs(1:nb)) allocate (bubmoms(1:nb, 1:nmom)) - do i = 1, num_fluids - gammas(i) = fluid_pp(i)%gamma - pi_infs(i) = fluid_pp(i)%pi_inf - end do -!$acc update device(gammas, pi_infs) + do i = 1, nb bubrs(i) = bub_idx%rs(i) @@ -200,7 +182,7 @@ contains coeffs = 0d0 - do i1 = 0, 2; do i2 = 0, 2 + do i2 = 0, 2; do i1 = 0, 2 if ((i1 + i2) <= 2) then if (bubble_model == 3) then ! RPE @@ -241,7 +223,8 @@ contains real(kind(0d0)), dimension(nb) :: Rvec real(kind(0d0)), dimension(nnode, nb) :: wght, abscX, abscY real(kind(0d0)), dimension(nterms, 0:2, 0:2) :: mom3d_terms, coeff - real(kind(0d0)) :: pres, rho, nbub, c, alf + real(kind(0d0)) :: pres, rho, nbub, c, alf, R3, momsum + real(kind(0d0)) :: start, finish real(kind(0d0)) :: n_tait, B_tait integer :: j, k, l, q, r, s !< Loop variables @@ -252,7 +235,8 @@ contains !$acc update device(is1, is2, is3) -!$acc parallel loop collapse(3) gang vector default(present) private(moms, Rvec, wght, abscX, abscY, mom3d_terms, coeff) + +!$acc parallel loop collapse(3) gang vector default(present) private(moms, wght, abscX, abscY, coeff) do id3 = is3%beg, is3%end do id2 = is2%beg, is2%end do id1 = is1%beg, is1%end @@ -279,12 +263,14 @@ contains if (alf > small_alf) then + R3 = 0d0 + !$acc loop seq do q = 1, nb - Rvec(q) = q_prim_vf(bubrs(q))%sf(id1, id2, id3) + R3 = R3 + weight(q)*q_prim_vf(bubrs(q))%sf(id1, id2, id3)**3d0 end do - call s_comp_n_from_prim(alf, Rvec, nbub) + nbub = (3.d0/(4.d0*pi))*alf/R3 !$acc loop seq do q = 1, nb @@ -293,48 +279,29 @@ contains moms(r) = q_prim_vf(bubmoms(q, r))%sf(id1, id2, id3) end do - ! IF(id1==0) THEN - ! PRINT*, 'pres: ', pres - ! PRINT*, 'nb : ', nbub - ! PRINT*, 'alf: ', alf - ! DO s = 1,nmom - ! PRINT*, 'mom: ', moms(s) - ! END DO - ! END IF + call s_chyqmom(moms, wght(:, q), abscX(:, q), abscY(:, q)) - !$acc loop seq - do j = 1, nterms - !$acc loop seq - do i2 = 0, 2 - !$acc loop seq - do i1 = 0, 2 - if ((i1 + i2) <= 2) then - - mom3d_terms(j, i1, i2) = coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q)) & - *f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), momrhs(:, i1, i2, j, q)) - end if - end do - end do - end do !$acc loop seq - do i1 = 0, 2 + do i2 = 0, 2 !$acc loop seq - do i2 = 0, 2 + do i1 = 0, 2 if ((i1 + i2) <= 2) then - moms3d(i1, i2, q)%sf(id1, id2, id3) = nbub*sum(mom3d_terms(:, i1, i2)) - ! IF (moms3d(i1,i2,q)%sf(id1,id2,id3) .NE. moms3d(i1,i2,q)%sf(id1,id2,id3)) THEN - ! PRINT*, 'nan in mom3d', i1,i2,id1 - ! PRINT*, 'nbu: ', nbub - ! PRINT*, 'alf: ', alf - ! PRINT*, 'moms: ', moms(:) - ! CALL s_mpi_abort() - ! END IF + momsum = 0d0 + !$acc loop seq + do j = 1, nterms + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q)) & + *f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), momrhs(:, i1, i2, j, q)) + end do + moms3d(i1, i2, q)%sf(id1, id2, id3) = nbub * momsum + end if end do end do + + end do momsp(1)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght, 3d0, 0d0, 0d0) @@ -347,19 +314,7 @@ contains momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght, 3d0*(1d0 - gam), 0d0, 3d0*gam) end if - !!$acc loop seq - !do i1 = 1, 4 - ! if (momsp(i1)%sf(id1, id2, id3) /= momsp(i1)%sf(id1, id2, id3)) then - ! print *, 'NaN in sp moment', i1, 'location', id1, id2, id3 - ! print *, 'Rs', Rvec(:) - ! print *, 'alpha', alf - ! print *, 'nbub', nbub - ! print *, 'abscX', abscX(:, :) - ! print *, 'abscY', abscY(:, :) - ! print *, 'wght', wght(:, :) - ! call s_mpi_abort() - !end if - !end do + else !$acc loop seq do q = 1, nb @@ -383,6 +338,7 @@ contains end do end do + end subroutine s_mom_inv subroutine s_chyqmom(momin, wght, abscX, abscY) diff --git a/src/simulation/m_rhs.f90 b/src/simulation/m_rhs.f90 index af10416e48..97534bb85d 100644 --- a/src/simulation/m_rhs.f90 +++ b/src/simulation/m_rhs.f90 @@ -5,7 +5,7 @@ !> @brief The module contains the subroutines used to calculate the right- !! hand-side (RHS) in the quasi-conservative, shock- and interface- !! capturing finite-volume framework for the multicomponent Navier- -!! f Stokes equations supplemented by appropriate advection equations +!! Stokes equations supplemented by appropriate advection equations !! used to capture the material interfaces. The system of equations !! is closed by the stiffened gas equation of state, as well as any !! required mixture relationships. Capillarity effects are included @@ -27,7 +27,6 @@ module m_rhs use m_weno !< Weighted and essentially non-oscillatory (WENO) !! schemes for spatial reconstruction of variables - use m_riemann_solvers !< Exact and approximate Riemann problem solvers use m_cbc !< Characteristic boundary conditions (CBC) @@ -39,6 +38,10 @@ module m_rhs use m_hypoelastic use nvtx + + use m_monopole + + use m_viscous ! ========================================================================== implicit none @@ -46,9 +49,8 @@ module m_rhs private; public :: s_initialize_rhs_module, & s_compute_rhs, & s_pressure_relaxation_procedure, & - s_populate_variables_buffers, & - s_finalize_rhs_module, & - s_get_viscous + s_finalize_rhs_module + type(vector_field) :: q_cons_qp !< !! This variable contains the WENO-reconstructed values of the cell-average @@ -141,6 +143,8 @@ module m_rhs type(int_bounds_info) :: is1, is2, is3 + type(int_bounds_info) :: ixt, iyt, izt + !> @name Bubble dynamic source terms !> @{ real(kind(0d0)), allocatable, dimension(:, :, :) :: bub_adv_src @@ -163,19 +167,10 @@ module m_rhs !> @} real(kind(0d0)), allocatable, dimension(:, :, :) :: blkmod1, blkmod2, alpha1, alpha2, Kterm - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: qL_rsx_vf_flat, qL_rsy_vf_flat, qL_rsz_vf_flat, qR_rsx_vf_flat, qR_rsy_vf_flat, qR_rsz_vf_flat - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: dqL_rsx_vf_flat, dqL_rsy_vf_flat, dqL_rsz_vf_flat, dqR_rsx_vf_flat, dqR_rsy_vf_flat, dqR_rsz_vf_flat - - integer :: momxb, momxe - integer :: contxb, contxe - integer :: advxb, advxe - integer :: intxb, intxe -!$acc declare create(intxb, intxe) + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf - integer :: bubxb, bubxe - integer :: strxb, strxe - real(kind(0d0)), allocatable, dimension(:) :: gammas, pi_infs -!$acc declare create(gammas, pi_infs) + real(kind(0d0)), allocatable, dimension(:) :: gamma_min, pres_inf !$acc declare create(gamma_min, pres_inf) @@ -183,18 +178,6 @@ module m_rhs real(kind(0d0)), allocatable, dimension(:, :) :: Res !$acc declare create(Res) - real(kind(0d0)), allocatable, dimension(:) :: mag, length, npulse, dir, delay -!$acc declare create(mag, length, npulse, dir, delay) - - integer, allocatable, dimension(:) :: pulse, support -!$acc declare create(pulse, support) - - real(kind(0d0)), allocatable, dimension(:, :) :: loc_mono -!$acc declare create(loc_mono) - - real(kind(0d0)), allocatable, dimension(:) :: foc_length, aperture -!$acc declare create(foc_length, aperture) - character(50) :: file_path !< Local file path for saving debug files !$acc declare create(q_cons_qp,q_prim_qp,qL_cons_n,qR_cons_n,qL_prim_n,qR_prim_n, & @@ -202,13 +185,13 @@ module m_rhs !$acc dqL_prim_dz_n,dqR_prim_dx_n,dqR_prim_dy_n,dqR_prim_dz_n,gm_alpha_qp, & !$acc gm_alphaL_n,gm_alphaR_n,flux_n,flux_src_n,flux_gsrc_n, & !$acc tau_Re_vf,qL_prim, qR_prim, iv,ix, iy, iz,is1,is2,is3,bub_adv_src,bub_r_src,bub_v_src, bub_p_src, bub_m_src, & -!$acc bub_mom_src, mono_mass_src, mono_e_src,mono_mom_src, myflux_vf, myflux_src_vf,alf_sum, momxb, momxe, contxb, contxe, advxb, advxe, bubxb, bubxe, strxb, strxe, & -!$acc blkmod1, blkmod2, alpha1, alpha2, Kterm, divu, qL_rsx_vf_flat, qL_rsy_vf_flat, qL_rsz_vf_flat, qR_rsx_vf_flat, qR_rsy_vf_flat, qR_rsz_vf_flat, & -!$acc dqL_rsx_vf_flat, dqL_rsy_vf_flat, dqL_rsz_vf_flat, dqR_rsx_vf_flat, dqR_rsy_vf_flat, dqR_rsz_vf_flat) +!$acc bub_mom_src, myflux_vf, myflux_src_vf,alf_sum, & +!$acc blkmod1, blkmod2, alpha1, alpha2, Kterm, divu, qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & +!$acc dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, & +!$acc ixt, iyt, izt) real(kind(0d0)), allocatable, dimension(:, :, :) :: nbub !< Bubble number density - integer, allocatable, dimension(:) :: rs, vs, ps, ms -!$acc declare create(nbub, rs, vs, ps, ms) +!$acc declare create(nbub) contains @@ -246,6 +229,8 @@ subroutine s_initialize_rhs_module() ! --------------------------------- !$acc iy%beg:iy%end, & !$acc iz%beg:iz%end)) end if + + ixt = ix; iyt = iy; izt = iz allocate (q_cons_qp%vf(1:sys_size)) allocate (q_prim_qp%vf(1:sys_size)) @@ -358,33 +343,33 @@ subroutine s_initialize_rhs_module() ! --------------------------------- end do ! END: Allocation/Association of qK_cons_n and qK_prim_n ===== - allocate (qL_rsx_vf_flat(ix%beg:ix%end, & + allocate (qL_rsx_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) - allocate (qR_rsx_vf_flat(ix%beg:ix%end, & + allocate (qR_rsx_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) if (n > 0) then - allocate (qL_rsy_vf_flat(iy%beg:iy%end, & + allocate (qL_rsy_vf(iy%beg:iy%end, & ix%beg:ix%end, iz%beg:iz%end, 1:sys_size)) - allocate (qR_rsy_vf_flat(iy%beg:iy%end, & + allocate (qR_rsy_vf(iy%beg:iy%end, & ix%beg:ix%end, iz%beg:iz%end, 1:sys_size)) else - allocate (qL_rsy_vf_flat(ix%beg:ix%end, & + allocate (qL_rsy_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) - allocate (qR_rsy_vf_flat(ix%beg:ix%end, & + allocate (qR_rsy_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) end if if (p > 0) then - allocate (qL_rsz_vf_flat(iz%beg:iz%end, & + allocate (qL_rsz_vf(iz%beg:iz%end, & iy%beg:iy%end, ix%beg:ix%end, 1:sys_size)) - allocate (qR_rsz_vf_flat(iz%beg:iz%end, & + allocate (qR_rsz_vf(iz%beg:iz%end, & iy%beg:iy%end, ix%beg:ix%end, 1:sys_size)) else - allocate (qL_rsz_vf_flat(ix%beg:ix%end, & + allocate (qL_rsz_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) - allocate (qR_rsz_vf_flat(ix%beg:ix%end, & + allocate (qR_rsz_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) end if @@ -512,38 +497,38 @@ subroutine s_initialize_rhs_module() ! --------------------------------- end do end if - ! END: Allocation/Association of dqK_prim_ds_n ================== + ! END: Allocation/Association of d K_prim_ds_n ================== if (any(Re_size > 0)) then if (weno_Re_flux) then - allocate (dqL_rsx_vf_flat(ix%beg:ix%end, & + allocate (dqL_rsx_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) - allocate (dqR_rsx_vf_flat(ix%beg:ix%end, & + allocate (dqR_rsx_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) if (n > 0) then - allocate (dqL_rsy_vf_flat(iy%beg:iy%end, & + allocate (dqL_rsy_vf(iy%beg:iy%end, & ix%beg:ix%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) - allocate (dqR_rsy_vf_flat(iy%beg:iy%end, & + allocate (dqR_rsy_vf(iy%beg:iy%end, & ix%beg:ix%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) else - allocate (dqL_rsy_vf_flat(ix%beg:ix%end, & + allocate (dqL_rsy_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) - allocate (dqR_rsy_vf_flat(ix%beg:ix%end, & + allocate (dqR_rsy_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) end if if (p > 0) then - allocate (dqL_rsz_vf_flat(iz%beg:iz%end, & + allocate (dqL_rsz_vf(iz%beg:iz%end, & iy%beg:iy%end, ix%beg:ix%end, mom_idx%beg:mom_idx%end)) - allocate (dqR_rsz_vf_flat(iz%beg:iz%end, & + allocate (dqR_rsz_vf(iz%beg:iz%end, & iy%beg:iy%end, ix%beg:ix%end, mom_idx%beg:mom_idx%end)) else - allocate (dqL_rsz_vf_flat(ix%beg:ix%end, & + allocate (dqL_rsz_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) - allocate (dqR_rsz_vf_flat(ix%beg:ix%end, & + allocate (dqR_rsz_vf(ix%beg:ix%end, & iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) end if @@ -570,9 +555,10 @@ subroutine s_initialize_rhs_module() ! --------------------------------- end if if (monopole) then - allocate (mono_mass_src(0:m, 0:n, 0:p)) - allocate (mono_mom_src(1:num_dims, 0:m, 0:n, 0:p)) - allocate (mono_E_src(0:m, 0:n, 0:p)) + allocate (mono_mass_src(0:m, 0:n, 0:p)) + allocate (mono_mom_src(1:num_dims, 0:m, 0:n, 0:p)) + allocate (mono_E_src(0:m, 0:n, 0:p)) +!$acc enter data create(mono_mass_src(0:m, 0:n, 0:p), mono_mom_src(1:num_dims, 0:m, 0:n, 0:p), mono_E_src(0:m, 0:n, 0:p)) end if allocate (divu%sf( & @@ -671,13 +657,7 @@ subroutine s_initialize_rhs_module() ! --------------------------------- allocate (blkmod1(0:m, 0:n, 0:p), blkmod2(0:m, 0:n, 0:p), alpha1(0:m, 0:n, 0:p), alpha2(0:m, 0:n, 0:p), Kterm(0:m, 0:n, 0:p)) end if - allocate (gammas(1:num_fluids), pi_infs(1:num_fluids)) - do i = 1, num_fluids - gammas(i) = fluid_pp(i)%gamma - pi_infs(i) = fluid_pp(i)%pi_inf - end do -!$acc update device(gammas, pi_infs) allocate (gamma_min(1:num_fluids), pres_inf(1:num_fluids)) @@ -700,64 +680,6 @@ subroutine s_initialize_rhs_module() ! --------------------------------- !$acc update device(Res, Re_idx, Re_size) end if - momxb = mom_idx%beg - momxe = mom_idx%end - advxb = adv_idx%beg - advxe = adv_idx%end - contxb = cont_idx%beg - contxe = cont_idx%end - bubxb = bub_idx%beg - bubxe = bub_idx%end - strxb = stress_idx%beg - strxe = stress_idx%end - intxb = internalEnergies_idx%beg - intxe = internalEnergies_idx%end - - if (bubbles) then - allocate (rs(1:nb)) - allocate (vs(1:nb)) - if (.not. polytropic) then - allocate (ps(1:nb)) - allocate (ms(1:nb)) - end if - - do l = 1, nb - rs(l) = bub_idx%rs(l) - vs(l) = bub_idx%vs(l) - if (.not. polytropic) then - ps(l) = bub_idx%ps(l) - ms(l) = bub_idx%ms(l) - end if - end do - -!$acc update device(rs, vs) - if (.not. polytropic) then -!$acc update device(ps, ms) - end if - - end if - - if (monopole) then - allocate(mag(1:num_mono), support(1:num_mono), length(1:num_mono), npulse(1:num_mono), pulse(1:num_mono), dir(1:num_mono), delay(1:num_mono), loc_mono(1:3, 1:num_mono), foc_length(1:num_mono), aperture(1:num_mono)) - - do i = 1, num_mono - mag(i) = mono(i)%mag - support(i) = mono(i)%support - length(i) = mono(i)%length - npulse(i) = mono(i)%npulse - pulse(i) = mono(i)%pulse - dir(i) = mono(i)%dir - delay(i) = mono(i)%delay - foc_length(i) = mono(i)%foc_length - aperture(i) = mono(i)%aperture - do j = 1, 3 - loc_mono(j, i) = mono(i)%loc(j) - end do - end do - !$acc update device(mag, support, length, npulse, pulse, dir, delay, foc_length, aperture, loc_mono) - end if - -!$acc update device(momxb, momxe, advxb, advxe, contxb, contxe, bubxb, bubxe, intxb, intxe, sys_size, buff_size, E_idx, alf_idx, strxb, strxe) ! Associating procedural pointer to the subroutine that will be ! utilized to calculate the solution of a given Riemann problem @@ -819,7 +741,7 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- type(scalar_field), dimension(sys_size), intent(INOUT) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(INOUT) :: rhs_vf integer, intent(IN) :: t_step - + real(kind(0d0)) :: top, bottom !< Numerator and denominator when evaluating flux limiter function real(kind(0d0)), dimension(num_fluids) :: myalpha_rho, myalpha @@ -837,6 +759,7 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- integer :: ndirs real(kind(0d0)) :: mytime, sound + real(kind(0d0)) :: start, finish real(kind(0d0)) :: s2, const_sos, s1 integer :: i, j, k, l, r, q, ii, id !< Generic loop iterators @@ -867,6 +790,8 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- call nvtxStartRange("RHS-MPI") call s_populate_conservative_variables_buffers() call nvtxEndRange + + ! ================================================================== ! Converting Conservative to Primitive Variables ================== @@ -900,16 +825,27 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- ix, iy, iz) call nvtxEndRange + + if (t_step == t_step_stop) return ! ================================================================== if (qbmm) call s_mom_inv(q_prim_qp%vf, mom_sp, mom_3d, ix, iy, iz) call nvtxStartRange("Viscous") - if (any(Re_size > 0)) call s_get_viscous() + if (any(Re_size > 0)) call s_get_viscous(qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, & + qL_prim, & + qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & + dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, & + qR_prim, & + q_prim_qp, & + dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, gm_vel_qp, & + ix, iy, iz) call nvtxEndRange() - + ! Dimensional Splitting Loop ======================================= + do id = 1, num_dims ! Configuring Coordinate Direction Indexes ====================== @@ -920,58 +856,58 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- ix%end = m - ix%beg; iy%end = n - iy%beg; iz%end = p - iz%beg ! =============================================================== ! Reconstructing Primitive/Conservative Variables =============== - + if (all(Re_size == 0)) then - iv%beg = 1; iv%end = sys_size + iv%beg = 1; iv%end = sys_size !call nvtxStartRange("RHS-WENO") call nvtxStartRange("RHS-WENO") - call s_reconstruct_cell_boundary_values_alt( & + call s_reconstruct_cell_boundary_values( & q_prim_qp%vf(1:sys_size), & - qL_rsx_vf_flat, qL_rsy_vf_flat, qL_rsz_vf_flat, & - qR_rsx_vf_flat, qR_rsy_vf_flat, qR_rsz_vf_flat, & + qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & id) call nvtxEndRange else call nvtxStartRange("RHS-WENO") iv%beg = 1; iv%end = contxe - call s_reconstruct_cell_boundary_values_alt( & + call s_reconstruct_cell_boundary_values( & q_prim_qp%vf(iv%beg:iv%end), & - qL_rsx_vf_flat, qL_rsy_vf_flat, qL_rsz_vf_flat, & - qR_rsx_vf_flat, qR_rsy_vf_flat, qR_rsz_vf_flat, & + qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & id) iv%beg = E_idx; iv%end = E_idx - call s_reconstruct_cell_boundary_values_alt( & + call s_reconstruct_cell_boundary_values( & q_prim_qp%vf(iv%beg:iv%end), & - qL_rsx_vf_flat, qL_rsy_vf_flat, qL_rsz_vf_flat, & - qR_rsx_vf_flat, qR_rsy_vf_flat, qR_rsz_vf_flat, & + qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & id) iv%beg = advxb; iv%end = advxe - call s_reconstruct_cell_boundary_values_alt( & + call s_reconstruct_cell_boundary_values( & q_prim_qp%vf(iv%beg:iv%end), & - qL_rsx_vf_flat, qL_rsy_vf_flat, qL_rsz_vf_flat, & - qR_rsx_vf_flat, qR_rsy_vf_flat, qR_rsz_vf_flat, & + qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & id) iv%beg = mom_idx%beg; iv%end = mom_idx%end if (weno_Re_flux) then call s_reconstruct_cell_boundary_values_visc_deriv( & dq_prim_dx_qp%vf(iv%beg:iv%end), & - dqL_rsx_vf_flat, dqL_rsy_vf_flat, dqL_rsz_vf_flat, & - dqR_rsx_vf_flat, dqR_rsy_vf_flat, dqR_rsz_vf_flat, & + dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, & + dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, & id, dqL_prim_dx_n(id)%vf(iv%beg:iv%end), dqR_prim_dx_n(id)%vf(iv%beg:iv%end)) if (n > 0) then call s_reconstruct_cell_boundary_values_visc_deriv( & dq_prim_dy_qp%vf(iv%beg:iv%end), & - dqL_rsx_vf_flat, dqL_rsy_vf_flat, dqL_rsz_vf_flat, & - dqR_rsx_vf_flat, dqR_rsy_vf_flat, dqR_rsz_vf_flat, & + dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, & + dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, & id, dqL_prim_dy_n(id)%vf(iv%beg:iv%end), dqR_prim_dy_n(id)%vf(iv%beg:iv%end)) if (p > 0) then call s_reconstruct_cell_boundary_values_visc_deriv( & dq_prim_dz_qp%vf(iv%beg:iv%end), & - dqL_rsx_vf_flat, dqL_rsy_vf_flat, dqL_rsz_vf_flat, & - dqR_rsx_vf_flat, dqR_rsy_vf_flat, dqR_rsz_vf_flat, & + dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, & + dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, & id, dqL_prim_dz_n(id)%vf(iv%beg:iv%end), dqR_prim_dz_n(id)%vf(iv%beg:iv%end)) end if end if @@ -992,12 +928,13 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- call nvtxStartRange("RHS-Riemann") ! Computing Riemann Solver Flux and Source Flux ================= - call s_riemann_solver(qR_rsx_vf_flat, qR_rsy_vf_flat, qR_rsz_vf_flat, & + + call s_riemann_solver(qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & dqR_prim_dx_n(id)%vf, & dqR_prim_dy_n(id)%vf, & dqR_prim_dz_n(id)%vf, & qR_prim(id)%vf, & - qL_rsx_vf_flat, qL_rsy_vf_flat, qL_rsz_vf_flat, & + qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & dqL_prim_dx_n(id)%vf, & dqL_prim_dy_n(id)%vf, & dqL_prim_dz_n(id)%vf, & @@ -1009,10 +946,9 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- id, ix, iy, iz) call nvtxEndRange -! iv%beg = 1; iv%end = sys_size - ! =============================================================== + if (alt_soundspeed) then !$acc parallel loop collapse(3) gang vector default(present) do l = 0, p @@ -1160,7 +1096,6 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- end do end do else - !$acc parallel loop collapse(3) gang vector default(present) do l = 0, p do k = 0, n @@ -1174,335 +1109,21 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- end do end do -!$acc parallel loop collapse(3) gang vector default(present) private(Rtmp, Vtmp) - do l = 0, p - do k = 0, n - do j = 0, m - bub_adv_src(j, k, l) = 0d0 - -!$acc loop seq - do q = 1, nb - bub_r_src(j, k, l, q) = 0d0 - bub_v_src(j, k, l, q) = 0d0 - bub_p_src(j, k, l, q) = 0d0 - bub_m_src(j, k, l, q) = 0d0 - end do - end do - end do - end do - ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 - if (id == ndirs) then - -!$acc parallel loop collapse(3) gang vector default(present) private(Rtmp, Vtmp) - do l = 0, p - do k = 0, n - do j = 0, m - -!$acc loop seq - do q = 1, nb - Rtmp(q) = q_prim_qp%vf(rs(q))%sf(j, k, l) - Vtmp(q) = q_prim_qp%vf(vs(q))%sf(j, k, l) - end do - - call s_comp_n_from_prim(q_prim_qp%vf(alf_idx)%sf(j, k, l), & - Rtmp, nbub(j, k, l)) - - call s_quad((Rtmp**2.d0)*Vtmp, R2Vav) - - bub_adv_src(j, k, l) = 4.d0*pi*nbub(j, k, l)*R2Vav - - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) private(myalpha_rho, myalpha) - do l = 0, p - do k = 0, n - do j = 0, m -!$acc loop seq - do q = 1, nb - - bub_r_src(j, k, l, q) = q_cons_qp%vf(vs(q))%sf(j, k, l) - -!$acc loop seq - do ii = 1, num_fluids - myalpha_rho(ii) = q_cons_qp%vf(ii)%sf(j, k, l) - myalpha(ii) = q_cons_qp%vf(advxb + ii - 1)%sf(j, k, l) - end do - - myRho = 0d0 - n_tait = 0d0 - B_tait = 0d0 - - if (mpp_lim .and. (num_fluids > 2)) then -!$acc loop seq - do ii = 1, num_fluids - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else if (num_fluids > 2) then -!$acc loop seq - do ii = 1, num_fluids - 1 - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else - myRho = myalpha_rho(1) - n_tait = gammas(1) - B_tait = pi_infs(1) - end if - - n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' - - myRho = q_prim_qp%vf(1)%sf(j, k, l) - myP = q_prim_qp%vf(E_idx)%sf(j, k, l) - alf = q_prim_qp%vf(alf_idx)%sf(j, k, l) - myR = q_prim_qp%vf(rs(q))%sf(j, k, l) - myV = q_prim_qp%vf(vs(q))%sf(j, k, l) - - if (.not. polytropic) then - pb = q_prim_qp%vf(ps(q))%sf(j, k, l) - mv = q_prim_qp%vf(ms(q))%sf(j, k, l) - call s_bwproperty(pb, q) - vflux = f_vflux(myR, myV, mv, q) - pbdot = f_bpres_dot(vflux, myR, myV, pb, mv, q) - - bub_p_src(j, k, l, q) = nbub(j, k, l)*pbdot - bub_m_src(j, k, l, q) = nbub(j, k, l)*vflux*4.d0*pi*(myR**2.d0) - else - pb = 0d0; mv = 0d0; vflux = 0d0; pbdot = 0d0 - end if - - if (bubble_model == 1) then - ! Gilmore bubbles - Cpinf = myP - pref - Cpbw = f_cpbw(R0(q), myR, myV, pb) - myH = f_H(Cpbw, Cpinf, n_tait, B_tait) - c_gas = f_cgas(Cpinf, n_tait, B_tait, myH) - Cpinf_dot = f_cpinfdot(myRho, myP, alf, n_tait, B_tait, bub_adv_src(j, k, l), divu%sf(j, k, l)) - myHdot = f_Hdot(Cpbw, Cpinf, Cpinf_dot, n_tait, B_tait, myR, myV, R0(q), pbdot) - rddot = f_rddot(Cpbw, myR, myV, myH, myHdot, c_gas, n_tait, B_tait) - else if (bubble_model == 2) then - ! Keller-Miksis bubbles - Cpinf = myP - Cpbw = f_cpbw_KM(R0(q), myR, myV, pb) - ! c_gas = dsqrt( n_tait*(Cpbw+B_tait) / myRho) - c_liquid = DSQRT(n_tait*(myP + B_tait)/(myRho*(1.d0 - alf))) - rddot = f_rddot_KM(pbdot, Cpinf, Cpbw, myRho, myR, myV, R0(q), c_liquid) - else if (bubble_model == 3) then - ! Rayleigh-Plesset bubbles - Cpbw = f_cpbw_KM(R0(q), myR, myV, pb) - rddot = f_rddot_RP(myP, myRho, myR, myV, R0(q), Cpbw) - end if - - bub_v_src(j, k, l, q) = nbub(j, k, l)*rddot - - if (alf < 1.d-11) then - bub_adv_src(j, k, l) = 0d0 - bub_r_src(j, k, l, q) = 0d0 - bub_v_src(j, k, l, q) = 0d0 - if (.not. polytropic) then - bub_p_src(j, k, l, q) = 0d0 - bub_m_src(j, k, l, q) = 0d0 - end if - end if - end do - end do - end do - end do + if (id == ndirs) then + call s_compute_bubble_source(bub_adv_src, bub_r_src, bub_v_src, bub_p_src, bub_m_src, divu, nbub, & + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, rhs_vf) end if - -!$acc parallel loop collapse(3) gang vector default(present) - do l = 0, p - do q = 0, n - do i = 0, m - rhs_vf(alf_idx)%sf(i, q, l) = rhs_vf(alf_idx)%sf(i, q, l) + bub_adv_src(i, q, l) - if (num_fluids > 1) rhs_vf(advxb)%sf(i, q, l) = & - rhs_vf(advxb)%sf(i, q, l) - bub_adv_src(i, q, l) -!$acc loop seq - do k = 1, nb - rhs_vf(rs(k))%sf(i, q, l) = rhs_vf(rs(k))%sf(i, q, l) + bub_r_src(i, q, l, k) - rhs_vf(vs(k))%sf(i, q, l) = rhs_vf(vs(k))%sf(i, q, l) + bub_v_src(i, q, l, k) - if (polytropic .neqv. .true.) then - rhs_vf(ps(k))%sf(i, q, l) = rhs_vf(ps(k))%sf(i, q, l) + bub_p_src(i, q, l, k) - rhs_vf(ms(k))%sf(i, q, l) = rhs_vf(ms(k))%sf(i, q, l) + bub_m_src(i, q, l, k) - end if - end do - end do - end do - end do end if - end if + end if if (monopole) then -!$acc parallel loop collapse(3) gang vector default(present) - do l = 0, p - do k = 0, n - do j = 0, m - mono_mass_src(j, k, l) = 0d0; mono_mom_src(1, j, k, l) = 0d0; mono_e_src(j, k, l) = 0d0; - if (n > 0) then - mono_mom_src(2, j, k, l) = 0d0 - end if - if (p > 0) then - mono_mom_src(3, j, k, l) = 0d0 - end if - end do - end do - end do - ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 - if (id == ndirs) then -!$acc parallel loop collapse(3) gang vector default(present) private(myalpha_rho, myalpha) - do l = 0, p - do k = 0, n - do j = 0, m -!$acc loop seq - do q = 1, num_mono - - mytime = t_step*dt - if ((mytime >= delay(q)) .or. (delay(q) == dflt_real)) then - -!$acc loop seq - do ii = 1, num_fluids - myalpha_rho(ii) = q_cons_qp%vf(ii)%sf(j, k, l) - myalpha(ii) = q_cons_qp%vf(advxb + ii - 1)%sf(j, k, l) - end do - - myRho = 0d0 - n_tait = 0d0 - B_tait = 0d0 - - if (bubbles) then - if (mpp_lim .and. (num_fluids > 2)) then - !$acc loop seq - do ii = 1, num_fluids - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else if (num_fluids > 2) then - !$acc loop seq - do ii = 1, num_fluids - 1 - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else - myRho = myalpha_rho(1) - n_tait = gammas(1) - B_tait = pi_infs(1) - end if - else - !$acc loop seq - do ii = 1, num_fluids - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - end if - n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' - - sound = n_tait*(q_prim_qp%vf(E_idx)%sf(j, k, l) + ((n_tait - 1d0)/n_tait)*B_tait)/myRho - sound = dsqrt(sound) - -! const_sos = dsqrt(n_tait) - const_sos = n_tait*(1.01d5 + ((n_tait - 1d0)/n_tait)*B_tait)/myRho - const_sos = dsqrt(const_sos) - !TODO: does const_sos need to be changed? - - term_index = 2 - - angle = 0.d0 - angle_z = 0.d0 - - s2 = f_g(mytime, sound, const_sos, q, term_index)* & - f_delta(j, k, l, loc_mono(:, q), length(q), q, angle, angle_z) - - !s2 = 1d0 - - if (support(q) == 5) then - term_index = 1 - s1 = f_g(mytime, sound, const_sos, q, term_index)* & - f_delta(j, k, l, loc_mono(:, q), length(q), q, angle, angle_z) - end if - - mono_mass_src(j, k, l) = mono_mass_src(j, k, l) + s2/sound -! mono_mass_src(j, k, l) = mono_mass_src(j, k, l) + s2/const_sos - - if (n == 0) then - - ! 1D - if (dir(q) < -0.1d0) then - !left-going wave - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) - s2 - else - !right-going wave - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2 - end if - else if (p == 0) then - ! IF ( (j==1) .AND. (k==1) .AND. proc_rank == 0) & - ! PRINT*, '====== Monopole magnitude: ', f_g(mytime,sound,const_sos,mono(q)) - if (dir(q) /= dflt_real) then - ! 2d - !mono_mom_src(1,j,k,l) = s2 - !mono_mom_src(2,j,k,l) = s2 - if (support(q) == 5) then - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(angle) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(angle) - else - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(dir(q)) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(dir(q)) - end if - end if - else - ! 3D - if (dir(q) /= dflt_real) then - if (support(q) == 5) then - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(angle) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(angle) - else - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(dir(q)) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(dir(q)) - end if - end if - end if - - if (model_eqns /= 4) then - if (support(q) == 5) then -! mono_E_src(j, k, l) = mono_E_src(j, k, l) + s1*sound**2.d0/(n_tait - 1.d0) - mono_E_src(j, k, l) = mono_E_src(j, k, l) + s1*const_sos**2.d0/(n_tait - 1.d0) - else - mono_E_src(j, k, l) = mono_E_src(j, k, l) + s2*sound/(n_tait - 1.d0) - end if - end if - - end if - end do - end do - end do - end do - + if (id == ndirs) then + call s_monopole_calculations(mono_mass_src, mono_mom_src, mono_e_src, & + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, & + rhs_vf) end if - -!$acc parallel loop collapse(3) gang vector default(present) - do l = 0, p - do k = 0, n - do j = 0, m -!$acc loop seq - do q = contxb, contxe - rhs_vf(q)%sf(j, k, l) = rhs_vf(q)%sf(j, k, l) + mono_mass_src(j, k, l) - end do -!$acc loop seq - do q = momxb, momxe - rhs_vf(q)%sf(j, k, l) = rhs_vf(q)%sf(j, k, l) + mono_mom_src(q - contxe, j, k, l) - end do - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + mono_e_src(j, k, l) - end do - end do - end do end if if (model_eqns == 3) then @@ -1677,316 +1298,22 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- end do ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 - if (id == ndirs) then - -!$acc parallel loop collapse(3) gang vector default(present) private(Rtmp, Vtmp) - do l = 0, p - do k = 0, n - do j = 0, m - -!$acc loop seq - do q = 1, nb - Rtmp(q) = q_prim_qp%vf(rs(q))%sf(j, k, l) - Vtmp(q) = q_prim_qp%vf(vs(q))%sf(j, k, l) - end do - - call s_comp_n_from_prim(q_prim_qp%vf(alf_idx)%sf(j, k, l), & - Rtmp, nbub(j, k, l)) - - call s_quad((Rtmp**2.d0)*Vtmp, R2Vav) - - bub_adv_src(j, k, l) = 4.d0*pi*nbub(j, k, l)*R2Vav - - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) private(myalpha_rho, myalpha) - do l = 0, p - do k = 0, n - do j = 0, m -!$acc loop seq - do q = 1, nb - - bub_r_src(j, k, l, q) = q_cons_qp%vf(vs(q))%sf(j, k, l) - -!$acc loop seq - do ii = 1, num_fluids - myalpha_rho(ii) = q_cons_qp%vf(ii)%sf(j, k, l) - myalpha(ii) = q_cons_qp%vf(advxb + ii - 1)%sf(j, k, l) - end do - - myRho = 0d0 - n_tait = 0d0 - B_tait = 0d0 - - if (mpp_lim .and. (num_fluids > 2)) then -!$acc loop seq - do ii = 1, num_fluids - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else if (num_fluids > 2) then -!$acc loop seq - do ii = 1, num_fluids - 1 - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else - myRho = myalpha_rho(1) - n_tait = gammas(1) - B_tait = pi_infs(1) - end if - - n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' - - myRho = q_prim_qp%vf(1)%sf(j, k, l) - myP = q_prim_qp%vf(E_idx)%sf(j, k, l) - alf = q_prim_qp%vf(alf_idx)%sf(j, k, l) - myR = q_prim_qp%vf(rs(q))%sf(j, k, l) - myV = q_prim_qp%vf(vs(q))%sf(j, k, l) - - if (.not. polytropic) then - pb = q_prim_qp%vf(ps(q))%sf(j, k, l) - mv = q_prim_qp%vf(ms(q))%sf(j, k, l) - call s_bwproperty(pb, q) - vflux = f_vflux(myR, myV, mv, q) - pbdot = f_bpres_dot(vflux, myR, myV, pb, mv, q) - - bub_p_src(j, k, l, q) = nbub(j, k, l)*pbdot - bub_m_src(j, k, l, q) = nbub(j, k, l)*vflux*4.d0*pi*(myR**2.d0) - else - pb = 0d0; mv = 0d0; vflux = 0d0; pbdot = 0d0 - end if - - if (bubble_model == 1) then - ! Gilmore bubbles - Cpinf = myP - pref - Cpbw = f_cpbw(R0(q), myR, myV, pb) - myH = f_H(Cpbw, Cpinf, n_tait, B_tait) - c_gas = f_cgas(Cpinf, n_tait, B_tait, myH) - Cpinf_dot = f_cpinfdot(myRho, myP, alf, n_tait, B_tait, bub_adv_src(j, k, l), divu%sf(j, k, l)) - myHdot = f_Hdot(Cpbw, Cpinf, Cpinf_dot, n_tait, B_tait, myR, myV, R0(q), pbdot) - rddot = f_rddot(Cpbw, myR, myV, myH, myHdot, c_gas, n_tait, B_tait) - else if (bubble_model == 2) then - ! Keller-Miksis bubbles - Cpinf = myP - Cpbw = f_cpbw_KM(R0(q), myR, myV, pb) - ! c_gas = dsqrt( n_tait*(Cpbw+B_tait) / myRho) - c_liquid = DSQRT(n_tait*(myP + B_tait)/(myRho*(1.d0 - alf))) - rddot = f_rddot_KM(pbdot, Cpinf, Cpbw, myRho, myR, myV, R0(q), c_liquid) - else if (bubble_model == 3) then - ! Rayleigh-Plesset bubbles - Cpbw = f_cpbw_KM(R0(q), myR, myV, pb) - rddot = f_rddot_RP(myP, myRho, myR, myV, R0(q), Cpbw) - end if - - bub_v_src(j, k, l, q) = nbub(j, k, l)*rddot - - if (alf < 1.d-11) then - bub_adv_src(j, k, l) = 0d0 - bub_r_src(j, k, l, q) = 0d0 - bub_v_src(j, k, l, q) = 0d0 - if (.not. polytropic) then - bub_p_src(j, k, l, q) = 0d0 - bub_m_src(j, k, l, q) = 0d0 - end if - end if - end do - end do - end do - end do + if (id == ndirs) then + call s_compute_bubble_source(bub_adv_src, bub_r_src, bub_v_src, bub_p_src, bub_m_src, divu, nbub, & + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, rhs_vf) end if -!$acc parallel loop collapse(3) gang vector default(present) - do l = 0, p - do q = 0, n - do i = 0, m - rhs_vf(alf_idx)%sf(i, q, l) = rhs_vf(alf_idx)%sf(i, q, l) + bub_adv_src(i, q, l) - if (num_fluids > 1) rhs_vf(advxb)%sf(i, q, l) = & - rhs_vf(advxb)%sf(i, q, l) - bub_adv_src(i, q, l) -!$acc loop seq - do k = 1, nb - rhs_vf(rs(k))%sf(i, q, l) = rhs_vf(rs(k))%sf(i, q, l) + bub_r_src(i, q, l, k) - rhs_vf(vs(k))%sf(i, q, l) = rhs_vf(vs(k))%sf(i, q, l) + bub_v_src(i, q, l, k) - if (polytropic .neqv. .true.) then - rhs_vf(ps(k))%sf(i, q, l) = rhs_vf(ps(k))%sf(i, q, l) + bub_p_src(i, q, l, k) - rhs_vf(ms(k))%sf(i, q, l) = rhs_vf(ms(k))%sf(i, q, l) + bub_m_src(i, q, l, k) - end if - end do - end do - end do - end do end if - if (monopole) then -!$acc parallel loop collapse(3) gang vector default(present) - do l = 0, p - do k = 0, n - do j = 0, m - mono_mass_src(j, k, l) = 0d0; mono_mom_src(1, j, k, l) = 0d0; mono_e_src(j, k, l) = 0d0; - if (n > 0) then - mono_mom_src(2, j, k, l) = 0d0 - end if - if (p > 0) then - mono_mom_src(3, j, k, l) = 0d0 - end if - end do - end do - end do - - ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 - if (id == ndirs) then -!$acc parallel loop collapse(3) gang vector default(present) private(myalpha_rho, myalpha) - do l = 0, p - do k = 0, n - do j = 0, m -!$acc loop seq - do q = 1, num_mono - - mytime = t_step*dt - if ((mytime >= delay(q)) .or. (delay(q) == dflt_real)) then - -!$acc loop seq - do ii = 1, num_fluids - myalpha_rho(ii) = q_cons_qp%vf(ii)%sf(j, k, l) - myalpha(ii) = q_cons_qp%vf(advxb + ii - 1)%sf(j, k, l) - end do - myRho = 0d0 - n_tait = 0d0 - B_tait = 0d0 - - if (bubbles) then - if (mpp_lim .and. (num_fluids > 2)) then - !$acc loop seq - do ii = 1, num_fluids - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else if (num_fluids > 2) then - !$acc loop seq - do ii = 1, num_fluids - 1 - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else - myRho = myalpha_rho(1) - n_tait = gammas(1) - B_tait = pi_infs(1) - end if - else - !$acc loop seq - do ii = 1, num_fluids - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - end if - n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' - - sound = n_tait*(q_prim_qp%vf(E_idx)%sf(j, k, l) + ((n_tait - 1d0)/n_tait)*B_tait)/myRho - sound = dsqrt(sound) - -! const_sos = dsqrt(n_tait) - const_sos = n_tait*(1.01d5 + ((n_tait - 1d0)/n_tait)*B_tait)/myRho - const_sos = dsqrt(const_sos) - - term_index = 2 - - angle = 0.d0 - angle_z = 0.d0 - - s2 = f_g(mytime, sound, const_sos, q, term_index)* & - f_delta(j, k, l, loc_mono(:, q), length(q), q, angle, angle_z) - - !s2 = 1d0 - - if (support(q) == 5) then - term_index = 1 - s1 = f_g(mytime, sound, const_sos, q, term_index)* & - f_delta(j, k, l, loc_mono(:, q), length(q), q, angle, angle_z) - end if - mono_mass_src(j, k, l) = mono_mass_src(j, k, l) + s2/sound -! mono_mass_src(j, k, l) = mono_mass_src(j, k, l) + s2/const_sos -! end if - - if (n == 0) then - - ! 1D - if (dir(q) < -0.1d0) then - !left-going wave - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) - s2 - else - !right-going wave - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2 - end if - else if (p == 0) then - ! IF ( (j==1) .AND. (k==1) .AND. proc_rank == 0) & - ! PRINT*, '====== Monopole magnitude: ', f_g(mytime,sound,const_sos,mono(q)) - - if (dir(q) /= dflt_real) then - ! 2d - !mono_mom_src(1,j,k,l) = s2 - !mono_mom_src(2,j,k,l) = s2 - if (support(q) == 5) then - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(angle) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(angle) - else - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(dir(q)) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(dir(q)) - end if - end if - else - ! 3D - if (dir(q) /= dflt_real) then - if (support(q) == 5) then - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(angle) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(angle) - else - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(dir(q)) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(dir(q)) - end if - end if - end if - - if (model_eqns /= 4) then - if (support(q) == 5) then - mono_E_src(j, k, l) = mono_E_src(j, k, l) + s1*const_sos**2.d0/(n_tait - 1.d0) -! mono_E_src(j, k, l) = mono_E_src(j, k, l) + s1*sound**2.d0/(n_tait - 1.d0) - else - mono_E_src(j, k, l) = mono_E_src(j, k, l) + s2*sound/(n_tait - 1.d0) - end if - end if - - end if - end do - end do - end do - end do + if (monopole) then + ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 + if (id == ndirs) then + call s_monopole_calculations(mono_mass_src, mono_mom_src, mono_e_src, & + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, & + rhs_vf) end if - -!$acc parallel loop collapse(3) gang vector default(present) - do l = 0, p - do k = 0, n - do j = 0, m -!$acc loop seq - do q = contxb, contxe - rhs_vf(q)%sf(j, k, l) = rhs_vf(q)%sf(j, k, l) + mono_mass_src(j, k, l) - end do -!$acc loop seq - do q = momxb, momxe - rhs_vf(q)%sf(j, k, l) = rhs_vf(q)%sf(j, k, l) + mono_mom_src(q - contxe, j, k, l) - end do - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + mono_e_src(j, k, l) - end do - end do - end do end if if (model_eqns == 3) then @@ -2047,12 +1374,16 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- call s_compute_viscous_stress_tensor(q_prim_qp%vf, & dq_prim_dx_qp%vf(mom_idx%beg:mom_idx%end), & dq_prim_dy_qp%vf(mom_idx%beg:mom_idx%end), & - dq_prim_dz_qp%vf(mom_idx%beg:mom_idx%end)) + dq_prim_dz_qp%vf(mom_idx%beg:mom_idx%end), & + tau_Re_vf, & + ixt, iyt, izt) else call s_compute_viscous_stress_tensor(q_prim_qp%vf, & dq_prim_dx_qp%vf(mom_idx%beg:mom_idx%end), & dq_prim_dy_qp%vf(mom_idx%beg:mom_idx%end), & - dq_prim_dy_qp%vf(mom_idx%beg:mom_idx%end)) + dq_prim_dy_qp%vf(mom_idx%beg:mom_idx%end), & + tau_Re_vf, & + ixt, iyt, izt) end if !$acc parallel loop collapse(3) gang vector default(present) do l = 0, p @@ -2355,358 +1686,63 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- end do ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 - if (id == ndirs) then + if (id == ndirs) then + call s_compute_bubble_source(bub_adv_src, bub_r_src, bub_v_src, bub_p_src, bub_m_src, divu, nbub, & + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, rhs_vf) + end if -!$acc parallel loop collapse(3) gang vector default(present) private(Rtmp, Vtmp) - do l = 0, p - do k = 0, n - do j = 0, m + end if + call nvtxEndRange() -!$acc loop seq - do q = 1, nb - Rtmp(q) = q_prim_qp%vf(rs(q))%sf(j, k, l) - Vtmp(q) = q_prim_qp%vf(vs(q))%sf(j, k, l) - end do + call nvtxStartRange("Monopole") - call s_comp_n_from_prim(q_prim_qp%vf(alf_idx)%sf(j, k, l), & - Rtmp, nbub(j, k, l)) + if (monopole) then + ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 + if (id == ndirs) then + call s_monopole_calculations(mono_mass_src, mono_mom_src, mono_e_src, & + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, & + rhs_vf) + end if + end if - call s_quad((Rtmp**2.d0)*Vtmp, R2Vav) + call nvtxEndRange() - bub_adv_src(j, k, l) = 4.d0*pi*nbub(j, k, l)*R2Vav + if (model_eqns == 3) then +!$acc parallel loop collapse(4) gang vector default(present) + do l = 0, p + do k = 0, n + do j = 0, m + do i = 1, num_fluids + rhs_vf(i + intxb - 1)%sf(j, k, l) = & + rhs_vf(i + intxb - 1)%sf(j, k, l) - 1d0/dz(l)* & + q_cons_qp%vf(i + advxb - 1)%sf(j, k, l)* & + q_prim_qp%vf(E_idx)%sf(j, k, l)* & + (flux_src_n(3)%vf(advxb)%sf(j, k, l) - & + flux_src_n(3)%vf(advxb)%sf(j, k, l - 1)) + end do + end do + end do + end do + end if + if (any(Re_size > 0)) then +!$acc parallel loop collapse(3) gang vector default(present) + do l = 0, p + do k = 0, n + do j = 0, m +!$acc loop seq + do i = momxb, E_idx + rhs_vf(i)%sf(j, k, l) = & + rhs_vf(i)%sf(j, k, l) + 1d0/dz(l)* & + (flux_src_n(3)%vf(i)%sf(j, k, l - 1) & + - flux_src_n(3)%vf(i)%sf(j, k, l)) end do end do end do + end do -!$acc parallel loop collapse(3) gang vector default(present) private(myalpha_rho, myalpha) - do l = 0, p - do k = 0, n - do j = 0, m -!$acc loop seq - do q = 1, nb - - bub_r_src(j, k, l, q) = q_cons_qp%vf(vs(q))%sf(j, k, l) - -!$acc loop seq - do ii = 1, num_fluids - myalpha_rho(ii) = q_cons_qp%vf(ii)%sf(j, k, l) - myalpha(ii) = q_cons_qp%vf(advxb + ii - 1)%sf(j, k, l) - end do - - myRho = 0d0 - n_tait = 0d0 - B_tait = 0d0 - - if (mpp_lim .and. (num_fluids > 2)) then -!$acc loop seq - do ii = 1, num_fluids - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else if (num_fluids > 2) then -!$acc loop seq - do ii = 1, num_fluids - 1 - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else - myRho = myalpha_rho(1) - n_tait = gammas(1) - B_tait = pi_infs(1) - end if - - n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' - - myRho = q_prim_qp%vf(1)%sf(j, k, l) - myP = q_prim_qp%vf(E_idx)%sf(j, k, l) - alf = q_prim_qp%vf(alf_idx)%sf(j, k, l) - myR = q_prim_qp%vf(rs(q))%sf(j, k, l) - myV = q_prim_qp%vf(vs(q))%sf(j, k, l) - - if (.not. polytropic) then - pb = q_prim_qp%vf(ps(q))%sf(j, k, l) - mv = q_prim_qp%vf(ms(q))%sf(j, k, l) - call s_bwproperty(pb, q) - vflux = f_vflux(myR, myV, mv, q) - pbdot = f_bpres_dot(vflux, myR, myV, pb, mv, q) - - bub_p_src(j, k, l, q) = nbub(j, k, l)*pbdot - bub_m_src(j, k, l, q) = nbub(j, k, l)*vflux*4.d0*pi*(myR**2.d0) - else - pb = 0d0; mv = 0d0; vflux = 0d0; pbdot = 0d0 - end if - - if (bubble_model == 1) then - ! Gilmore bubbles - Cpinf = myP - pref - Cpbw = f_cpbw(R0(q), myR, myV, pb) - myH = f_H(Cpbw, Cpinf, n_tait, B_tait) - c_gas = f_cgas(Cpinf, n_tait, B_tait, myH) - Cpinf_dot = f_cpinfdot(myRho, myP, alf, n_tait, B_tait, bub_adv_src(j, k, l), divu%sf(j, k, l)) - myHdot = f_Hdot(Cpbw, Cpinf, Cpinf_dot, n_tait, B_tait, myR, myV, R0(q), pbdot) - rddot = f_rddot(Cpbw, myR, myV, myH, myHdot, c_gas, n_tait, B_tait) - else if (bubble_model == 2) then - ! Keller-Miksis bubbles - Cpinf = myP - Cpbw = f_cpbw_KM(R0(q), myR, myV, pb) - ! c_gas = dsqrt( n_tait*(Cpbw+B_tait) / myRho) - c_liquid = DSQRT(n_tait*(myP + B_tait)/(myRho*(1.d0 - alf))) - rddot = f_rddot_KM(pbdot, Cpinf, Cpbw, myRho, myR, myV, R0(q), c_liquid) - else if (bubble_model == 3) then - ! Rayleigh-Plesset bubbles - Cpbw = f_cpbw_KM(R0(q), myR, myV, pb) - rddot = f_rddot_RP(myP, myRho, myR, myV, R0(q), Cpbw) - end if - - bub_v_src(j, k, l, q) = nbub(j, k, l)*rddot - - if (alf < 1.d-11) then - bub_adv_src(j, k, l) = 0d0 - bub_r_src(j, k, l, q) = 0d0 - bub_v_src(j, k, l, q) = 0d0 - if (.not. polytropic) then - bub_p_src(j, k, l, q) = 0d0 - bub_m_src(j, k, l, q) = 0d0 - end if - end if - end do - end do - end do - end do - end if - -!$acc parallel loop collapse(3) gang vector default(present) - do l = 0, p - do q = 0, n - do i = 0, m - rhs_vf(alf_idx)%sf(i, q, l) = rhs_vf(alf_idx)%sf(i, q, l) + bub_adv_src(i, q, l) - if (num_fluids > 1) rhs_vf(advxb)%sf(i, q, l) = & - rhs_vf(advxb)%sf(i, q, l) - bub_adv_src(i, q, l) -!$acc loop seq - do k = 1, nb - rhs_vf(rs(k))%sf(i, q, l) = rhs_vf(rs(k))%sf(i, q, l) + bub_r_src(i, q, l, k) - rhs_vf(vs(k))%sf(i, q, l) = rhs_vf(vs(k))%sf(i, q, l) + bub_v_src(i, q, l, k) - if (polytropic .neqv. .true.) then - rhs_vf(ps(k))%sf(i, q, l) = rhs_vf(ps(k))%sf(i, q, l) + bub_p_src(i, q, l, k) - rhs_vf(ms(k))%sf(i, q, l) = rhs_vf(ms(k))%sf(i, q, l) + bub_m_src(i, q, l, k) - end if - end do - end do - end do - end do - end if - call nvtxEndRange() - - call nvtxStartRange("Monopole") - if (monopole) then -!$acc parallel loop collapse(3) gang vector default(present) - do l = 0, p - do k = 0, n - do j = 0, m - mono_mass_src(j, k, l) = 0d0; mono_mom_src(1, j, k, l) = 0d0; mono_e_src(j, k, l) = 0d0; - if (n > 0) then - mono_mom_src(2, j, k, l) = 0d0 - end if - if (p > 0) then - mono_mom_src(3, j, k, l) = 0d0 - end if - end do - end do - end do - - ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 - if (id == ndirs) then -!$acc parallel loop collapse(3) gang vector default(present) private(myalpha_rho, myalpha) - do l = 0, p - do k = 0, n - do j = 0, m -!$acc loop seq - do q = 1, num_mono - - mytime = t_step*dt - if ((mytime >= delay(q)) .or. (delay(q) == dflt_real)) then - -!$acc loop seq - do ii = 1, num_fluids - myalpha_rho(ii) = q_cons_qp%vf(ii)%sf(j, k, l) - myalpha(ii) = q_cons_qp%vf(advxb + ii - 1)%sf(j, k, l) - end do - - myRho = 0d0 - n_tait = 0d0 - B_tait = 0d0 - - if (bubbles) then - if (mpp_lim .and. (num_fluids > 2)) then - !$acc loop seq - do ii = 1, num_fluids - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else if (num_fluids > 2) then - !$acc loop seq - do ii = 1, num_fluids - 1 - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - else - myRho = myalpha_rho(1) - n_tait = gammas(1) - B_tait = pi_infs(1) - end if - else - !$acc loop seq - do ii = 1, num_fluids - myRho = myRho + myalpha_rho(ii) - n_tait = n_tait + myalpha(ii)*gammas(ii) - B_tait = B_tait + myalpha(ii)*pi_infs(ii) - end do - end if - n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' - - sound = n_tait*(q_prim_qp%vf(E_idx)%sf(j, k, l) + ((n_tait - 1d0)/n_tait)*B_tait)/myRho - sound = dsqrt(sound) - -! const_sos = dsqrt(n_tait) - const_sos = n_tait*(1.01d5 + ((n_tait - 1d0)/n_tait)*B_tait)/myRho - const_sos = dsqrt(const_sos) - !TODO: change const_sos expression? - - term_index = 2 - - angle = 0.d0 - angle_z = 0.d0 - - s2 = f_g(mytime, sound, const_sos, q, term_index)* & - f_delta(j, k, l, loc_mono(:, q), length(q), q, angle, angle_z) - - !s2 = 1d0 - - if (support(q) == 5) then - term_index = 1 - s1 = f_g(mytime, sound, const_sos, q, term_index)* & - f_delta(j, k, l, mono(q)%loc, mono(q)%length, q, angle, angle_z) - end if - - mono_mass_src(j, k, l) = mono_mass_src(j, k, l) + s2/sound -! mono_mass_src(j, k, l) = mono_mass_src(j, k, l) + s2/const_sos - - if (n == 0) then - - ! 1D - if (dir(q) < -0.1d0) then - !left-going wave - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) - s2 - else - !right-going wave - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2 - end if - else if (p == 0) then - ! IF ( (j==1) .AND. (k==1) .AND. proc_rank == 0) & - ! PRINT*, '====== Monopole magnitude: ', f_g(mytime,sound,const_sos,mono(q)) - - if (dir(q) /= dflt_real) then - ! 2d - !mono_mom_src(1,j,k,l) = s2 - !mono_mom_src(2,j,k,l) = s2 - if (support(q) == 5) then - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(angle) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(angle) - else - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(dir(q)) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(dir(q)) - end if - end if - else - ! 3D - if (dir(q) /= dflt_real) then - if (support(q) == 5) then - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(angle) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(angle) - else - mono_mom_src(1, j, k, l) = mono_mom_src(1, j, k, l) + s2*cos(dir(q)) - mono_mom_src(2, j, k, l) = mono_mom_src(2, j, k, l) + s2*sin(dir(q)) - end if - end if - end if - - if (model_eqns /= 4) then - if (support(q) == 5) then -! mono_E_src(j, k, l) = mono_E_src(j, k, l) + s1*sound**2.d0/(n_tait - 1.d0) - mono_E_src(j, k, l) = mono_E_src(j, k, l) + s1*const_sos**2.d0/(n_tait - 1.d0) - else - mono_E_src(j, k, l) = mono_E_src(j, k, l) + s2*sound/(n_tait - 1.d0) - end if - end if - - end if - end do - end do - end do - end do - - end if - -!$acc parallel loop collapse(3) gang vector default(present) - do l = 0, p - do k = 0, n - do j = 0, m -!$acc loop seq - do q = contxb, contxe - rhs_vf(q)%sf(j, k, l) = rhs_vf(q)%sf(j, k, l) + mono_mass_src(j, k, l) - end do -!$acc loop seq - do q = momxb, momxe - rhs_vf(q)%sf(j, k, l) = rhs_vf(q)%sf(j, k, l) + mono_mom_src(q - contxe, j, k, l) - end do - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + mono_e_src(j, k, l) - end do - end do - end do - end if - call nvtxEndRange() - - if (model_eqns == 3) then -!$acc parallel loop collapse(4) gang vector default(present) - do l = 0, p - do k = 0, n - do j = 0, m - do i = 1, num_fluids - rhs_vf(i + intxb - 1)%sf(j, k, l) = & - rhs_vf(i + intxb - 1)%sf(j, k, l) - 1d0/dz(l)* & - q_cons_qp%vf(i + advxb - 1)%sf(j, k, l)* & - q_prim_qp%vf(E_idx)%sf(j, k, l)* & - (flux_src_n(3)%vf(advxb)%sf(j, k, l) - & - flux_src_n(3)%vf(advxb)%sf(j, k, l - 1)) - end do - end do - end do - end do - end if - - if (any(Re_size > 0)) then -!$acc parallel loop collapse(3) gang vector default(present) - do l = 0, p - do k = 0, n - do j = 0, m -!$acc loop seq - do i = momxb, E_idx - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1d0/dz(l)* & - (flux_src_n(3)%vf(i)%sf(j, k, l - 1) & - - flux_src_n(3)%vf(i)%sf(j, k, l)) - end do - end do - end do - end do - - if (grid_geometry == 3) then -!$acc parallel loop collapse(3) gang vector default(present) + if (grid_geometry == 3) then +!$acc parallel loop collapse(3) gang vector default(present) do l = 0, p do k = 0, n do j = 0, m @@ -2765,1838 +1801,259 @@ subroutine s_compute_rhs(q_cons_vf, q_prim_vf, rhs_vf, t_step) ! ------- end subroutine s_compute_rhs ! ----------------------------------------- - !> The purpose of this subroutine is to compute the viscous - !! stress tensor for the cells directly next to the axis in - !! cylindrical coordinates. This is necessary to avoid the - !! 1/r singularity that arises at the cell boundary coinciding - !! with the axis, i.e., y_cb(-1) = 0. - !! @param q_prim_vf Cell-average primitive variables - !! @param grad_x_vf Cell-average primitive variable derivatives, x-dir - !! @param grad_y_vf Cell-average primitive variable derivatives, y-dir - !! @param grad_z_vf Cell-average primitive variable derivatives, z-dir - subroutine s_compute_viscous_stress_tensor(q_prim_vf, grad_x_vf, grad_y_vf, grad_z_vf) ! --- - - type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf - type(scalar_field), dimension(num_dims), intent(IN) :: grad_x_vf, grad_y_vf, grad_z_vf - - real(kind(0d0)) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables - real(kind(0d0)), dimension(2) :: Re_visc - real(kind(0d0)), dimension(num_fluids) :: alpha_visc, alpha_rho_visc - - real(kind(0d0)), dimension(num_dims, num_dims) :: tau_Re + !> The purpose of this procedure is to infinitely relax + !! the pressures from the internal-energy equations to a + !! unique pressure, from which the corresponding volume + !! fraction of each phase are recomputed. For conservation + !! purpose, this pressure is finally corrected using the + !! mixture-total-energy equation. + !! @param q_cons_vf Cell-average conservative variables + subroutine s_pressure_relaxation_procedure(q_cons_vf) ! ---------------- - integer :: i, j, k, l, q !< Generic loop iterator + type(scalar_field), dimension(sys_size), intent(INOUT) :: q_cons_vf - ix%beg = -buff_size; iy%beg = 0; iz%beg = 0 - if (n > 0) iy%beg = -buff_size; if (p > 0) iz%beg = -buff_size - ix%end = m - ix%beg; iy%end = n - iy%beg; iz%end = p - iz%beg + !> @name Relaxed pressure, initial partial pressures, function f(p) and its partial + !! derivative df(p), isentropic partial density, sum of volume fractions, + !! mixture density, dynamic pressure, surface energy, specific heat ratio + !! function, liquid stiffness function (two variations of the last two + !! ones), shear and volume Reynolds numbers and the Weber numbers + !> @{ + real(kind(0d0)) :: pres_relax + real(kind(0d0)), dimension(num_fluids) :: pres_K_init + real(kind(0d0)) :: f_pres + real(kind(0d0)) :: df_pres + real(kind(0d0)), dimension(num_fluids) :: rho_K_s + real(kind(0d0)), dimension(num_fluids) :: alpha_rho + real(kind(0d0)), dimension(num_fluids) :: alpha + real(kind(0d0)) :: sum_alpha + real(kind(0d0)) :: rho + real(kind(0d0)) :: dyn_pres + real(kind(0d0)) :: gamma + real(kind(0d0)) :: pi_inf + real(kind(0d0)), dimension(2) :: Re - !$acc update device(ix, iy, iz) + integer :: i, j, k, l, q, iter !< Generic loop iterators + integer :: relax !< Relaxation procedure determination variable -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg, ix%end -!$acc loop seq - do i = momxb, E_idx - tau_Re_vf(i)%sf(j, k, l) = 0d0 - end do - end do - end do - end do +!$acc parallel loop collapse(3) gang vector private(pres_K_init, rho_K_s, alpha_rho, alpha, Re, pres_relax) + do l = 0, p + do k = 0, n + do j = 0, m - if (Re_size(1) > 0) then ! Shear stresses -!$acc parallel loop collapse(3) gang vector default(present) private(alpha_visc, alpha_rho_visc, Re_visc, tau_Re ) - do l = iz%beg, iz%end - do k = -1, 1 - do j = ix%beg, ix%end + ! Numerical correction of the volume fractions + if (mpp_lim) then + sum_alpha = 0d0 -!$acc loop seq + !$acc loop seq do i = 1, num_fluids - alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) - alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) - end do - - if (bubbles) then - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 - - if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then -!$acc loop seq - do i = 1, num_fluids - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - else if ((model_eqns == 2) .and. (num_fluids > 2)) then -!$acc loop seq - do i = 1, num_fluids - 1 - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - else - rho_visc = alpha_rho_visc(1) - gamma_visc = gammas(1) - pi_inf_visc = pi_infs(1) + if ((q_cons_vf(i + contxb - 1)%sf(j, k, l) < 0d0) .or. & + (q_cons_vf(i + advxb - 1)%sf(j, k, l) < 0d0)) then + q_cons_vf(i + contxb - 1)%sf(j, k, l) = 0d0 + q_cons_vf(i + advxb - 1)%sf(j, k, l) = 0d0 + q_cons_vf(i + intxb - 1)%sf(j, k, l) = 0d0 end if - else - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 - alpha_visc_sum = 0d0 - - if (mpp_lim) then -!$acc loop seq - do i = 1, num_fluids - alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) - alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) - alpha_visc_sum = alpha_visc_sum + alpha_visc(i) - end do + if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > 1d0) & + q_cons_vf(i + advxb - 1)%sf(j, k, l) = 1d0 + sum_alpha = sum_alpha + q_cons_vf(i + advxb - 1)%sf(j, k, l) + end do - alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) + !$acc loop seq + do i = 1, num_fluids + q_cons_vf(i + advxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, l)/sum_alpha + end do + end if - end if + ! Pressures relaxation procedure =================================== -!$acc loop seq - do i = 1, num_fluids - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do + ! Is the pressure relaxation procedure necessary? + relax = 1 - if (any(Re_size > 0)) then -!$acc loop seq - do i = 1, 2 - Re_visc(i) = dflt_real + !$acc loop seq + do i = 1, num_fluids + if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > (1d0 - sgm_eps)) relax = 0 + end do - if (Re_size(i) > 0) Re_visc(i) = 0d0 -!$acc loop seq - do q = 1, Re_size(i) - Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & - + Re_visc(i) - end do + if (relax == 1) then + ! Initial state + pres_relax = 0d0 - Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) + !$acc loop seq + do i = 1, num_fluids + if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) then + pres_K_init(i) = & + (q_cons_vf(i + intxb - 1)%sf(j, k, l)/ & + q_cons_vf(i + advxb - 1)%sf(j, k, l) & + - pi_infs(i))/gammas(i) - end do + if (pres_K_init(i) <= -(1d0 - 1d-8)*pres_inf(i) + 1d-8) & + pres_K_init(i) = -(1d0 - 1d-8)*pres_inf(i) + 1d-8 + else + pres_K_init(i) = 0d0 end if - end if - - tau_Re(2, 1) = (grad_y_vf(1)%sf(j, k, l) + & - grad_x_vf(2)%sf(j, k, l))/ & - Re_visc(1) - - tau_Re(2, 2) = (4d0*grad_y_vf(2)%sf(j, k, l) & - - 2d0*grad_x_vf(1)%sf(j, k, l) & - - 2d0*q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/ & - (3d0*Re_visc(1)) -!$acc loop seq - do i = 1, 2 - tau_Re_vf(contxe + i)%sf(j, k, l) = & - tau_Re_vf(contxe + i)%sf(j, k, l) - & - tau_Re(2, i) - - tau_Re_vf(E_idx)%sf(j, k, l) = & - tau_Re_vf(E_idx)%sf(j, k, l) - & - q_prim_vf(contxe + i)%sf(j, k, l)*tau_Re(2, i) + pres_relax = pres_relax + q_cons_vf(i + advxb - 1)%sf(j, k, l)*pres_K_init(i) end do - end do - end do - end do - end if - if (Re_size(2) > 0) then ! Bulk stresses -!$acc parallel loop collapse(3) gang vector default(present) private(alpha_visc, alpha_rho_visc, Re_visc, tau_Re ) - do l = iz%beg, iz%end - do k = -1, 1 - do j = ix%beg, ix%end + ! Iterative process for relaxed pressure determination + f_pres = 1d-9 + df_pres = 1d9 -!$acc loop seq + !$acc loop seq do i = 1, num_fluids - alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) - alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) + rho_K_s(i) = 0d0 end do - if (bubbles) then - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 - - if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then -!$acc loop seq - do i = 1, num_fluids - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - else if ((model_eqns == 2) .and. (num_fluids > 2)) then -!$acc loop seq - do i = 1, num_fluids - 1 - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - else - rho_visc = alpha_rho_visc(1) - gamma_visc = gammas(1) - pi_inf_visc = pi_infs(1) - end if - else - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 + !$acc loop seq + do iter = 0, 49 - alpha_visc_sum = 0d0 + if (DABS(f_pres) > 1d-10) then + pres_relax = pres_relax - f_pres/df_pres - if (mpp_lim) then -!$acc loop seq + ! Physical pressure do i = 1, num_fluids - alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) - alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) - alpha_visc_sum = alpha_visc_sum + alpha_visc(i) + if (pres_relax <= -(1d0 - 1d-8)*pres_inf(i) + 1d-8) & + pres_relax = -(1d0 - 1d-8)*pres_inf(i) + 1d0 end do - alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - - end if + ! Newton-Raphson method + f_pres = -1d0 + df_pres = 0d0 -!$acc loop seq - do i = 1, num_fluids - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - - if (any(Re_size > 0)) then -!$acc loop seq - do i = 1, 2 - Re_visc(i) = dflt_real - - if (Re_size(i) > 0) Re_visc(i) = 0d0 -!$acc loop seq - do q = 1, Re_size(i) - Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & - + Re_visc(i) - end do - - Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) - - end do - end if - end if - - tau_Re(2, 2) = (grad_x_vf(1)%sf(j, k, l) + & - grad_y_vf(2)%sf(j, k, l) + & - q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/ & - Re_visc(2) - - tau_Re_vf(momxb + 1)%sf(j, k, l) = & - tau_Re_vf(momxb + 1)%sf(j, k, l) - & - tau_Re(2, 2) - - tau_Re_vf(E_idx)%sf(j, k, l) = & - tau_Re_vf(E_idx)%sf(j, k, l) - & - q_prim_vf(momxb + 1)%sf(j, k, l)*tau_Re(2, 2) - - end do - end do - end do - end if - - if (p == 0) return - - if (Re_size(1) > 0) then ! Shear stresses -!$acc parallel loop collapse(3) gang vector default(present) private(alpha_visc, alpha_rho_visc, Re_visc, tau_Re ) - do l = iz%beg, iz%end - do k = -1, 1 - do j = ix%beg, ix%end - -!$acc loop seq - do i = 1, num_fluids - alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) - alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) - end do - - if (bubbles) then - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 - - if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then -!$acc loop seq - do i = 1, num_fluids - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - else if ((model_eqns == 2) .and. (num_fluids > 2)) then -!$acc loop seq - do i = 1, num_fluids - 1 - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - else - rho_visc = alpha_rho_visc(1) - gamma_visc = gammas(1) - pi_inf_visc = pi_infs(1) - end if - else - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 - - alpha_visc_sum = 0d0 - - if (mpp_lim) then -!$acc loop seq + !$acc loop seq do i = 1, num_fluids - alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) - alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) - alpha_visc_sum = alpha_visc_sum + alpha_visc(i) - end do - - alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - - end if - -!$acc loop seq - do i = 1, num_fluids - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - - if (any(Re_size > 0)) then -!$acc loop seq - do i = 1, 2 - Re_visc(i) = dflt_real - - if (Re_size(i) > 0) Re_visc(i) = 0d0 -!$acc loop seq - do q = 1, Re_size(i) - Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & - + Re_visc(i) - end do + if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) then + rho_K_s(i) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/ & + max(q_cons_vf(i + advxb - 1)%sf(j, k, l), sgm_eps) & + *((pres_relax + pres_inf(i))/(pres_K_init(i) + & + pres_inf(i)))**(1d0/gamma_min(i)) - Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) + f_pres = f_pres + q_cons_vf(i + contxb - 1)%sf(j, k, l) & + /rho_K_s(i) + df_pres = df_pres - q_cons_vf(i + contxb - 1)%sf(j, k, l) & + /(gamma_min(i)*rho_K_s(i)*(pres_relax + pres_inf(i))) + end if end do end if - end if - - tau_Re(2, 2) = -(2d0/3d0)*grad_z_vf(3)%sf(j, k, l)/y_cc(k)/ & - Re_visc(1) - - tau_Re(2, 3) = ((grad_z_vf(2)%sf(j, k, l) - & - q_prim_vf(momxe)%sf(j, k, l))/ & - y_cc(k) + grad_y_vf(3)%sf(j, k, l))/ & - Re_visc(1) -!$acc loop seq - do i = 2, 3 - tau_Re_vf(contxe + i)%sf(j, k, l) = & - tau_Re_vf(contxe + i)%sf(j, k, l) - & - tau_Re(2, i) - - tau_Re_vf(E_idx)%sf(j, k, l) = & - tau_Re_vf(E_idx)%sf(j, k, l) - & - q_prim_vf(contxe + i)%sf(j, k, l)*tau_Re(2, i) end do - end do - end do - end do - end if - - if (Re_size(2) > 0) then ! Bulk stresses -!$acc parallel loop collapse(3) gang vector default(present) private(alpha_visc, alpha_rho_visc, Re_visc, tau_Re ) - do l = iz%beg, iz%end - do k = -1, 1 - do j = ix%beg, ix%end - -!$acc loop seq + ! Cell update of the volume fraction + !$acc loop seq do i = 1, num_fluids - alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) - alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) + if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) & + q_cons_vf(i + advxb - 1)%sf(j, k, l) = q_cons_vf(i + contxb - 1)%sf(j, k, l) & + /rho_K_s(i) end do + end if - if (bubbles) then - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 - - if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then -!$acc loop seq - do i = 1, num_fluids - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - else if ((model_eqns == 2) .and. (num_fluids > 2)) then -!$acc loop seq - do i = 1, num_fluids - 1 - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - else - rho_visc = alpha_rho_visc(1) - gamma_visc = gammas(1) - pi_inf_visc = pi_infs(1) - end if - else - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 - - alpha_visc_sum = 0d0 - - if (mpp_lim) then -!$acc loop seq - do i = 1, num_fluids - alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) - alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) - alpha_visc_sum = alpha_visc_sum + alpha_visc(i) - end do - - alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - - end if - -!$acc loop seq - do i = 1, num_fluids - rho_visc = rho_visc + alpha_rho_visc(i) - gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) - pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) - end do - - if (any(Re_size > 0)) then -!$acc loop seq - do i = 1, 2 - Re_visc(i) = dflt_real - - if (Re_size(i) > 0) Re_visc(i) = 0d0 -!$acc loop seq - do q = 1, Re_size(i) - Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & - + Re_visc(i) - end do - - Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) - - end do - end if - end if - - tau_Re(2, 2) = grad_z_vf(3)%sf(j, k, l)/y_cc(k)/ & - Re_visc(2) - - tau_Re_vf(momxb + 1)%sf(j, k, l) = & - tau_Re_vf(momxb + 1)%sf(j, k, l) - & - tau_Re(2, 2) - - tau_Re_vf(E_idx)%sf(j, k, l) = & - tau_Re_vf(E_idx)%sf(j, k, l) - & - q_prim_vf(momxb + 1)%sf(j, k, l)*tau_Re(2, 2) - - end do - end do - end do - end if - - end subroutine s_compute_viscous_stress_tensor ! ---------------------------------------- - - !> This function gives the temporally varying amplitude of the pulse - !! @param mytime Simulation time - !! @param sos Sound speed - !! @param mysos Alternative speed of sound for testing - function f_g(mytime, sos, mysos, nm, term_index) -!$acc routine seq - real(kind(0d0)), intent(IN) :: mytime, sos, mysos - integer, intent(IN) :: nm - real(kind(0d0)) :: period, t0, sigt, pa - real(kind(0d0)) :: offset - real(kind(0d0)) :: f_g - integer :: term_index - - offset = 0d0 - if (delay(nm) /= dflt_real) offset = delay(nm) - - if (pulse(nm) == 1) then - ! Sine wave - period = length(nm)/sos - f_g = 0d0 - if (term_index == 1) then - f_g = mag(nm)*sin((mytime)*2.d0*pi/period)/mysos & - + mag(nm)/foc_length(nm)*(1.d0/(2.d0*pi/period)*cos((mytime)*2.d0*pi/period) & - - 1.d0/(2.d0*pi/period)) - elseif (mytime <= (npulse(nm)*period + offset)) then - f_g = mag(nm)*sin((mytime + offset)*2.d0*pi/period) - end if - else if (pulse(nm) == 2) then - ! Gaussian pulse - sigt = length(nm)/sos/7.d0 - t0 = 3.5d0*sigt - f_g = mag(nm)/(dsqrt(2.d0*pi)*sigt)* & - dexp(-0.5d0*((mytime - t0)**2.d0)/(sigt**2.d0)) - else if (pulse(nm) == 3) then - ! Square wave - sigt = length(nm)/sos - t0 = 0d0; f_g = 0d0 - if (mytime > t0 .and. mytime < sigt) then - f_g = mag(nm) - end if - else - end if - - end function f_g - - !> This function give the spatial support of the acoustic source - !! @param j First coordinate-direction location index - !! @param k Second coordinate-direction location index - !! @param l Third coordinate-direction location index - !! @param mono_loc Nominal source term location - !! @param mono_leng Length of source term in space - function f_delta(j, k, l, mono_loc, mono_leng, nm, angle, angle_z) -!$acc routine seq - real(kind(0d0)), dimension(3), intent(IN) :: mono_loc - integer, intent(IN) :: nm - real(kind(0d0)), intent(IN) :: mono_leng - integer, intent(in) :: j, k, l - - integer :: q - real(kind(0d0)) :: h, hx, hy, hz - real(kind(0d0)) :: hxnew, hynew - real(kind(0d0)) :: sig - real(kind(0d0)) :: f_delta - real(kind(0d0)) :: angle - real(kind(0d0)) :: angle_z - - if (n == 0) then - sig = dx(j) - sig = sig*2.5d0 - else if (p == 0) then - sig = maxval((/dx(j), dy(k)/)) - sig = sig*2.5d0 - else - sig = maxval((/dx(j), dy(k), dz(l)/)) - sig = sig*2.5d0 - end if - - if (n == 0) then !1D - if (support(nm) == 1) then - ! 1D delta function - hx = abs(mono_loc(1) - x_cc(j)) - - f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & - dexp(-0.5d0*(hx/(sig/2.d0))**2.d0) - else if (support(nm) == 0) then - ! Support for all x - f_delta = 1.d0 - end if - else if (p == 0) then !2D - hx = mono_loc(1) - x_cc(j) - hy = mono_loc(2) - y_cc(k) - if (support(nm) == 1) then - ! 2D delta function - sig = mono_leng/20.d0 - h = dsqrt(hx**2.d0 + hy**2.d0) - - f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & - dexp(-0.5d0*((h/(sig/2.d0))**2.d0)) - else if (support(nm) == 2) then - !only support for y \pm some value - if (abs(hy) < length(nm)) then - f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & - dexp(-0.5d0*(hx/(sig/2.d0))**2.d0) - else - f_delta = 0d0 - end if - else if (support(nm) == 3) then - ! Only support along some line - hx = x_cc(j) - mono_loc(1) - hy = y_cc(k) - mono_loc(2) - - ! Rotate actual point by -theta - hxnew = cos(dir(nm))*hx + sin(dir(nm))*hy - hynew = -1.d0*sin(dir(nm))*hx + cos(dir(nm))*hy - if (abs(hynew) < mono_loc(3)/2.d0) then - f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & - dexp(-0.5d0*(hxnew/(sig/2.d0))**2.d0) - else - f_delta = 0d0 - end if - else if (support(nm) == 4) then - ! Support for all y - f_delta = 1.d0/(dsqrt(2.d0*pi)*sig)* & - dexp(-0.5d0*(hx/sig)**2.d0) - else if (support(nm) == 5) then - ! Support along 'transducer' - hx = x_cc(j) - mono_loc(1) - hy = y_cc(k) - mono_loc(2) - - hxnew = foc_length(nm) - dsqrt(hy**2.d0 + (foc_length(nm) - hx)**2.d0) - if ((abs(hy) < aperture(nm)/2.d0) .and. (hx < foc_length(nm))) then - f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & - dexp(-0.5d0*(hxnew/(sig/2.d0))**2.d0) - angle = -atan(hy/(foc_length(nm) - hx)) - else - f_delta = 0d0 - end if - end if - else !3D - - hx = x_cc(j) - mono_loc(1) - hy = y_cc(k) - mono_loc(2) - hz = z_cc(l) - mono_loc(3) - if (support(nm) == 3) then - - ! Rotate actual point by -theta - hxnew = cos(dir(nm))*hx + sin(dir(nm))*hy - hynew = -1.d0*sin(dir(nm))*hx + cos(dir(nm))*hy - - if (abs(hynew) < length(nm)/2. .and. & - abs(hz) < length(nm)/2.) then - f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & - dexp(-0.5d0*(hxnew/(sig/2.d0))**2.d0) - else - f_delta = 0d0 - end if - else if (support(nm) == 4) then - ! Support for all x,y - f_delta = 1.d0/(dsqrt(2.d0*pi)*sig)* & - dexp(-0.5d0*(hz/sig)**2.d0) - else if (support(nm) == 5) then - ! Support along 'transducer' - hx = x_cc(j) - mono_loc(1) - hy = y_cc(k) - mono_loc(2) - hz = z_cc(l) - mono_loc(3) - - hxnew = foc_length(nm) - dsqrt(hy**2.d0 + hz**2.d0 + (foc_length(nm) - hx)**2.d0) - if ((dsqrt(hy**2.d0 + hz**2.d0) < aperture(nm)/2.d0) .and. & - (hx < foc_length(nm))) then - - f_delta = 1.d0/(dsqrt(2.d0*pi)*sig/2.d0)* & - dexp(-0.5d0*(hxnew/(sig/2.d0))**2.d0) - - angle = -atan(hy/(foc_length(nm) - hx)) - angle_z = -atan(hz/(foc_length(nm) - hx)) - else - f_delta = 0d0 - end if - end if - end if - - end function f_delta - - !> Computes the scalar gradient fields via finite differences - !! @param var Variable to compute derivative of - !! @param grad_x First coordinate direction component of the derivative - !! @param grad_y Second coordinate direction component of the derivative - !! @param grad_z Third coordinate direction component of the derivative - !! @param norm Norm of the gradient vector - subroutine s_compute_fd_gradient(var, grad_x, grad_y, grad_z, norm) - - type(scalar_field), intent(IN) :: var - type(scalar_field), intent(INOUT) :: grad_x - type(scalar_field), intent(INOUT) :: grad_y - type(scalar_field), intent(INOUT) :: grad_z - type(scalar_field), intent(INOUT) :: norm - - integer :: j, k, l !< Generic loop iterators - - ix%beg = -buff_size; ix%end = m + buff_size; - if (n > 0) then - iy%beg = -buff_size; iy%end = n + buff_size - else - iy%beg = -1; iy%end = 1 - end if - - if (p > 0) then - iz%beg = -buff_size; iz%end = p + buff_size - else - iz%beg = -1; iz%end = 1 - end if - - !$acc update device(ix, iy, iz) + ! ================================================================== -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg + 1, iz%end - 1 - do k = iy%beg + 1, iy%end - 1 - do j = ix%beg + 1, ix%end - 1 - grad_x%sf(j, k, l) = & - (var%sf(j + 1, k, l) - var%sf(j - 1, k, l))/ & - (x_cc(j + 1) - x_cc(j - 1)) - end do - end do - end do + ! Mixture-total-energy correction ================================== - if (n > 0) then -!$acc parallel loop collapse(3) gang vector - do l = iz%beg + 1, iz%end - 1 - do k = iy%beg + 1, iy%end - 1 - do j = ix%beg + 1, ix%end - 1 - grad_y%sf(j, k, l) = & - (var%sf(j, k + 1, l) - var%sf(j, k - 1, l))/ & - (y_cc(k + 1) - y_cc(k - 1)) - end do - end do - end do - end if + ! The mixture-total-energy correction of the mixture pressure P is not necessary here + ! because the primitive variables are directly recovered later on by the conservative + ! variables (see s_convert_conservative_to_primitive_variables called in s_compute_rhs). + ! However, the internal-energy equations should be reset with the corresponding mixture + ! pressure from the correction. This step is carried out below. - if (p > 0) then -!$acc parallel loop collapse(3) gang vector - do l = iz%beg + 1, iz%end - 1 - do k = iy%beg + 1, iy%end - 1 - do j = ix%beg + 1, ix%end - 1 - grad_z%sf(j, k, l) = & - (var%sf(j, k, l + 1) - var%sf(j, k, l - 1))/ & - (z_cc(l + 1) - z_cc(l - 1)) + !$acc loop seq + do i = 1, num_fluids + alpha_rho(i) = q_cons_vf(i)%sf(j, k, l) + alpha(i) = q_cons_vf(E_idx + i)%sf(j, k, l) end do - end do - end do - end if - - ix%beg = -buff_size; ix%end = m + buff_size; - if (n > 0) then - iy%beg = -buff_size; iy%end = n + buff_size - else - iy%beg = 0; iy%end = 0 - end if - - if (p > 0) then - iz%beg = -buff_size; iz%end = p + buff_size - else - iz%beg = 0; iz%end = 0 - end if - - !$acc update device(ix, iy, iz) -!$acc parallel loop collapse(2) gang vector default(present) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - grad_x%sf(ix%beg, k, l) = & - (-3d0*var%sf(ix%beg, k, l) + 4d0*var%sf(ix%beg + 1, k, l) - var%sf(ix%beg + 2, k, l))/ & - (x_cc(ix%beg + 2) - x_cc(ix%beg)) - grad_x%sf(ix%end, k, l) = & - (3d0*var%sf(ix%end, k, l) - 4d0*var%sf(ix%end - 1, k, l) + var%sf(ix%end - 2, k, l))/ & - (x_cc(ix%end) - x_cc(ix%end - 2)) - end do - end do - if (n > 0) then -!$acc parallel loop collapse(2) gang vector default(present) - do l = iz%beg, iz%end - do j = ix%beg, ix%end - grad_y%sf(j, iy%beg, l) = & - (-3d0*var%sf(j, iy%beg, l) + 4d0*var%sf(j, iy%beg + 1, l) - var%sf(j, iy%beg + 2, l))/ & - (y_cc(iy%beg + 2) - y_cc(iy%beg)) - grad_y%sf(j, iy%end, l) = & - (3d0*var%sf(j, iy%end, l) - 4d0*var%sf(j, iy%end - 1, l) + var%sf(j, iy%end - 2, l))/ & - (y_cc(iy%end) - y_cc(iy%end - 2)) - end do - end do - if (p > 0) then -!$acc parallel loop collapse(2) gang vector default(present) - do k = iy%beg, iy%end - do j = ix%beg, ix%end - grad_z%sf(j, k, iz%beg) = & - (-3d0*var%sf(j, k, iz%beg) + 4d0*var%sf(j, k, iz%beg + 1) - var%sf(j, k, iz%beg + 2))/ & - (z_cc(iz%beg + 2) - z_cc(iz%beg)) - grad_z%sf(j, k, iz%end) = & - (3d0*var%sf(j, k, iz%end) - 4d0*var%sf(j, k, iz%end - 1) + var%sf(j, k, iz%end - 2))/ & - (z_cc(iz%end) - z_cc(iz%end - 2)) - end do - end do - end if - end if + if (bubbles) then + rho = 0d0 + gamma = 0d0 + pi_inf = 0d0 - if (bc_x%beg <= -3) then -!$acc parallel loop collapse(2) gang vector default(present) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - grad_x%sf(0, k, l) = (-3d0*var%sf(0, k, l) + 4d0*var%sf(1, k, l) - var%sf(2, k, l))/ & - (x_cc(2) - x_cc(0)) - end do - end do - end if - if (bc_x%end <= -3) then -!$acc parallel loop collapse(2) gang vector default(present) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - grad_x%sf(m, k, l) = (3d0*var%sf(m, k, l) - 4d0*var%sf(m - 1, k, l) + var%sf(m - 2, k, l))/ & - (x_cc(m) - x_cc(m - 2)) - end do - end do - end if - if (n > 0) then - if (bc_y%beg <= -3 .and. bc_y%beg /= -13) then -!$acc parallel loop collapse(2) gang vector default(present) - do l = iz%beg, iz%end - do j = ix%beg, ix%end - grad_y%sf(j, 0, l) = (-3d0*var%sf(j, 0, l) + 4d0*var%sf(j, 1, l) - var%sf(j, 2, l))/ & - (y_cc(2) - y_cc(0)) - end do - end do - end if - if (bc_y%end <= -3) then -!$acc parallel loop collapse(2) gang vector default(present) - do l = iz%beg, iz%end - do j = ix%beg, ix%end - grad_y%sf(j, n, l) = (3d0*var%sf(j, n, l) - 4d0*var%sf(j, n - 1, l) + var%sf(j, n - 2, l))/ & - (y_cc(n) - y_cc(n - 2)) - end do - end do - end if - if (p > 0) then - if (bc_z%beg <= -3) then -!$acc parallel loop collapse(2) gang vector default(present) - do k = iy%beg, iy%end - do j = ix%beg, ix%end - grad_z%sf(j, k, 0) = & - (-3d0*var%sf(j, k, 0) + 4d0*var%sf(j, k, 1) - var%sf(j, k, 2))/ & - (z_cc(2) - z_cc(0)) - end do - end do - end if - if (bc_z%end <= -3) then -!$acc parallel loop collapse(2) gang vector default(present) - do k = iy%beg, iy%end - do j = ix%beg, ix%end - grad_z%sf(j, k, p) = & - (3d0*var%sf(j, k, p) - 4d0*var%sf(j, k, p - 1) + var%sf(j, k, p - 2))/ & - (z_cc(p) - z_cc(p - 2)) - end do - end do - end if - end if - end if - - end subroutine s_compute_fd_gradient ! -------------------------------------- - - !> The purpose of this procedure is to infinitely relax - !! the pressures from the internal-energy equations to a - !! unique pressure, from which the corresponding volume - !! fraction of each phase are recomputed. For conservation - !! purpose, this pressure is finally corrected using the - !! mixture-total-energy equation. - !! @param q_cons_vf Cell-average conservative variables - subroutine s_pressure_relaxation_procedure(q_cons_vf) ! ---------------- - - type(scalar_field), dimension(sys_size), intent(INOUT) :: q_cons_vf - - !> @name Relaxed pressure, initial partial pressures, function f(p) and its partial - !! derivative df(p), isentropic partial density, sum of volume fractions, - !! mixture density, dynamic pressure, surface energy, specific heat ratio - !! function, liquid stiffness function (two variations of the last two - !! ones), shear and volume Reynolds numbers and the Weber numbers - !> @{ - real(kind(0d0)) :: pres_relax - real(kind(0d0)), dimension(num_fluids) :: pres_K_init - real(kind(0d0)) :: f_pres - real(kind(0d0)) :: df_pres - real(kind(0d0)), dimension(num_fluids) :: rho_K_s - real(kind(0d0)), dimension(num_fluids) :: alpha_rho - real(kind(0d0)), dimension(num_fluids) :: alpha - real(kind(0d0)) :: sum_alpha - real(kind(0d0)) :: rho - real(kind(0d0)) :: dyn_pres - real(kind(0d0)) :: gamma - real(kind(0d0)) :: pi_inf - real(kind(0d0)), dimension(2) :: Re - - integer :: i, j, k, l, q, iter !< Generic loop iterators - integer :: relax !< Relaxation procedure determination variable - -!$acc parallel loop collapse(3) gang vector private(pres_K_init, rho_K_s, alpha_rho, alpha, Re, pres_relax) - do l = 0, p - do k = 0, n - do j = 0, m - - ! Numerical correction of the volume fractions - if (mpp_lim) then - sum_alpha = 0d0 - - !$acc loop seq - do i = 1, num_fluids - if ((q_cons_vf(i + contxb - 1)%sf(j, k, l) < 0d0) .or. & - (q_cons_vf(i + advxb - 1)%sf(j, k, l) < 0d0)) then - q_cons_vf(i + contxb - 1)%sf(j, k, l) = 0d0 - q_cons_vf(i + advxb - 1)%sf(j, k, l) = 0d0 - q_cons_vf(i + intxb - 1)%sf(j, k, l) = 0d0 - end if - - if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > 1d0) & - q_cons_vf(i + advxb - 1)%sf(j, k, l) = 1d0 - sum_alpha = sum_alpha + q_cons_vf(i + advxb - 1)%sf(j, k, l) - end do - - !$acc loop seq - do i = 1, num_fluids - q_cons_vf(i + advxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, l)/sum_alpha - end do - end if - - ! Pressures relaxation procedure =================================== - - ! Is the pressure relaxation procedure necessary? - relax = 1 - - !$acc loop seq - do i = 1, num_fluids - if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > (1d0 - sgm_eps)) relax = 0 - end do - - if (relax == 1) then - ! Initial state - pres_relax = 0d0 - - !$acc loop seq - do i = 1, num_fluids - if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) then - pres_K_init(i) = & - (q_cons_vf(i + intxb - 1)%sf(j, k, l)/ & - q_cons_vf(i + advxb - 1)%sf(j, k, l) & - - pi_infs(i))/gammas(i) - - if (pres_K_init(i) <= -(1d0 - 1d-8)*pres_inf(i) + 1d-8) & - pres_K_init(i) = -(1d0 - 1d-8)*pres_inf(i) + 1d-8 - else - pres_K_init(i) = 0d0 - end if - pres_relax = pres_relax + q_cons_vf(i + advxb - 1)%sf(j, k, l)*pres_K_init(i) - end do - - ! Iterative process for relaxed pressure determination - f_pres = 1d-9 - df_pres = 1d9 - - !$acc loop seq - do i = 1, num_fluids - rho_K_s(i) = 0d0 - end do - - !$acc loop seq - do iter = 0, 49 - - if (DABS(f_pres) > 1d-10) then - pres_relax = pres_relax - f_pres/df_pres - - ! Physical pressure - do i = 1, num_fluids - if (pres_relax <= -(1d0 - 1d-8)*pres_inf(i) + 1d-8) & - pres_relax = -(1d0 - 1d-8)*pres_inf(i) + 1d0 - end do - - ! Newton-Raphson method - f_pres = -1d0 - df_pres = 0d0 - - !$acc loop seq - do i = 1, num_fluids - if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) then - rho_K_s(i) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/ & - max(q_cons_vf(i + advxb - 1)%sf(j, k, l), sgm_eps) & - *((pres_relax + pres_inf(i))/(pres_K_init(i) + & - pres_inf(i)))**(1d0/gamma_min(i)) - - f_pres = f_pres + q_cons_vf(i + contxb - 1)%sf(j, k, l) & - /rho_K_s(i) - - df_pres = df_pres - q_cons_vf(i + contxb - 1)%sf(j, k, l) & - /(gamma_min(i)*rho_K_s(i)*(pres_relax + pres_inf(i))) - end if - end do - end if - - end do - - ! Cell update of the volume fraction - !$acc loop seq - do i = 1, num_fluids - if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) & - q_cons_vf(i + advxb - 1)%sf(j, k, l) = q_cons_vf(i + contxb - 1)%sf(j, k, l) & - /rho_K_s(i) - end do - end if - - ! ================================================================== - - ! Mixture-total-energy correction ================================== - - ! The mixture-total-energy correction of the mixture pressure P is not necessary here - ! because the primitive variables are directly recovered later on by the conservative - ! variables (see s_convert_conservative_to_primitive_variables called in s_compute_rhs). - ! However, the internal-energy equations should be reset with the corresponding mixture - ! pressure from the correction. This step is carried out below. - - !$acc loop seq - do i = 1, num_fluids - alpha_rho(i) = q_cons_vf(i)%sf(j, k, l) - alpha(i) = q_cons_vf(E_idx + i)%sf(j, k, l) - end do - - if (bubbles) then - rho = 0d0 - gamma = 0d0 - pi_inf = 0d0 - - if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then - !$acc loop seq - do i = 1, num_fluids - rho = rho + alpha_rho(i) - gamma = gamma + alpha(i)*gammas(i) - pi_inf = pi_inf + alpha(i)*pi_infs(i) - end do - else if ((model_eqns == 2) .and. (num_fluids > 2)) then - !$acc loop seq - do i = 1, num_fluids - 1 - rho = rho + alpha_rho(i) - gamma = gamma + alpha(i)*gammas(i) - pi_inf = pi_inf + alpha(i)*pi_infs(i) - end do - else - rho = alpha_rho(1) - gamma = gammas(1) - pi_inf = pi_infs(1) - end if - else - rho = 0d0 - gamma = 0d0 - pi_inf = 0d0 - - sum_alpha = 0d0 - - if (mpp_lim) then - !$acc loop seq - do i = 1, num_fluids - alpha_rho(i) = max(0d0, alpha_rho(i)) - alpha(i) = min(max(0d0, alpha(i)), 1d0) - sum_alpha = sum_alpha + alpha(i) - end do - - alpha = alpha/max(sum_alpha, sgm_eps) - - end if - - !$acc loop seq - do i = 1, num_fluids - rho = rho + alpha_rho(i) - gamma = gamma + alpha(i)*gammas(i) - pi_inf = pi_inf + alpha(i)*pi_infs(i) - end do - - if (any(Re_size > 0)) then - !$acc loop seq - do i = 1, 2 - Re(i) = dflt_real - - if (Re_size(i) > 0) Re(i) = 0d0 - !$acc loop seq - do q = 1, Re_size(i) - Re(i) = alpha(Re_idx(i, q))/Res(i, q) & - + Re(i) - end do - - Re(i) = 1d0/max(Re(i), sgm_eps) - - end do - end if - end if - - dyn_pres = 0d0 - - !$acc loop seq - do i = momxb, momxe - dyn_pres = dyn_pres + 5d-1*q_cons_vf(i)%sf(j, k, l)* & - q_cons_vf(i)%sf(j, k, l)/max(rho, sgm_eps) - end do - - pres_relax = (q_cons_vf(E_idx)%sf(j, k, l) - dyn_pres - pi_inf)/gamma - - !$acc loop seq - do i = 1, num_fluids - q_cons_vf(i + intxb - 1)%sf(j, k, l) = & - q_cons_vf(i + advxb - 1)%sf(j, k, l)* & - (gammas(i)*pres_relax + pi_infs(i)) - end do - ! ================================================================== - end do - end do - end do - - end subroutine s_pressure_relaxation_procedure ! ----------------------- - - !> This subroutine compute the TVD flux function - !! @param q_cons_vf Cell-averaged conservative variables - !! @param q_prim_vf Cell-averaged primitive variables - !! @param rhs_vf Cell-averaged RHS variables - !! @param i Dimensional splitting index - - !> Computes viscous terms - !! @param q_cons_vf Cell-averaged conservative variables - !! @param q_prim_vf Cell-averaged primitive variables - !! @param rhs_vf Cell-averaged RHS variables - subroutine s_get_viscous() ! ------- - - integer :: i, j, k, l, r !< Generic loop iterators - - !$acc update device(ix, iy, iz) - - do i = 1, num_dims - - iv%beg = mom_idx%beg; iv%end = mom_idx%end - - !$acc update device(iv) - - call s_reconstruct_cell_boundary_values_visc( & - q_prim_qp%vf(iv%beg:iv%end), & - qL_rsx_vf_flat, qL_rsy_vf_flat, qL_rsz_vf_flat, & - qR_rsx_vf_flat, qR_rsy_vf_flat, qR_rsz_vf_flat, & - i, qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end)) - end do - - if (weno_Re_flux) then - ! Compute velocity gradient at cell centers using scalar - ! divergence theorem - do i = 1, num_dims - if (i == 1) then - call s_apply_scalar_divergence_theorem( & - qL_prim(i)%vf(iv%beg:iv%end), & - qR_prim(i)%vf(iv%beg:iv%end), & - dq_prim_dx_qp%vf(iv%beg:iv%end), i) - elseif (i == 2) then - call s_apply_scalar_divergence_theorem( & - qL_prim(i)%vf(iv%beg:iv%end), & - qR_prim(i)%vf(iv%beg:iv%end), & - dq_prim_dy_qp%vf(iv%beg:iv%end), i) - else - call s_apply_scalar_divergence_theorem( & - qL_prim(i)%vf(iv%beg:iv%end), & - qR_prim(i)%vf(iv%beg:iv%end), & - dq_prim_dz_qp%vf(iv%beg:iv%end), i) - end if - end do - - else ! Compute velocity gradient at cell centers using finite differences - - iv%beg = mom_idx%beg; iv%end = mom_idx%end - !$acc update device(iv) - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg + 1, ix%end -!$acc loop seq - do i = iv%beg, iv%end - dqL_prim_dx_n(1)%vf(i)%sf(j, k, l) = & - (q_prim_qp%vf(i)%sf(j, k, l) - & - q_prim_qp%vf(i)%sf(j - 1, k, l))/ & - (x_cc(j) - x_cc(j - 1)) - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg, ix%end - 1 -!$acc loop seq - do i = iv%beg, iv%end - dqR_prim_dx_n(1)%vf(i)%sf(j, k, l) = & - (q_prim_qp%vf(i)%sf(j + 1, k, l) - & - q_prim_qp%vf(i)%sf(j, k, l))/ & - (x_cc(j + 1) - x_cc(j)) - end do - end do - end do - end do - - if (n > 0) then - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg, iz%end - do j = iy%beg + 1, iy%end - do k = ix%beg, ix%end -!$acc loop seq - do i = iv%beg, iv%end - dqL_prim_dy_n(2)%vf(i)%sf(k, j, l) = & - (q_prim_qp%vf(i)%sf(k, j, l) - & - q_prim_qp%vf(i)%sf(k, j - 1, l))/ & - (y_cc(j) - y_cc(j - 1)) - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg, iz%end - do j = iy%beg, iy%end - 1 - do k = ix%beg, ix%end - !$acc loop seq - do i = iv%beg, iv%end - dqR_prim_dy_n(2)%vf(i)%sf(k, j, l) = & - (q_prim_qp%vf(i)%sf(k, j + 1, l) - & - q_prim_qp%vf(i)%sf(k, j, l))/ & - (y_cc(j + 1) - y_cc(j)) - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg, iz%end - do j = iy%beg + 1, iy%end - do k = ix%beg + 1, ix%end - 1 -!$acc loop seq - do i = iv%beg, iv%end - dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = & - (dqL_prim_dx_n(1)%vf(i)%sf(k, j, l) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, j, l) + & - dqL_prim_dx_n(1)%vf(i)%sf(k, j - 1, l) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, j - 1, l)) - - dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25d-2* & - dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg, iz%end - do j = iy%beg, iy%end - 1 - do k = ix%beg + 1, ix%end - 1 -!$acc loop seq - do i = iv%beg, iv%end - dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = & - (dqL_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + & - dqL_prim_dx_n(1)%vf(i)%sf(k, j, l) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, j, l)) - - dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25d-2* & - dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) - - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg, iz%end - do k = iy%beg + 1, iy%end - 1 - do j = ix%beg + 1, ix%end -!$acc loop seq - do i = iv%beg, iv%end - dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = & - (dqL_prim_dy_n(2)%vf(i)%sf(j, k, l) + & - dqR_prim_dy_n(2)%vf(i)%sf(j, k, l) + & - dqL_prim_dy_n(2)%vf(i)%sf(j - 1, k, l) + & - dqR_prim_dy_n(2)%vf(i)%sf(j - 1, k, l)) - - dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25d-2* & - dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) - - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg, iz%end - do k = iy%beg + 1, iy%end - 1 - do j = ix%beg, ix%end - 1 -!$acc loop seq - do i = iv%beg, iv%end - dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = & - (dqL_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + & - dqR_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + & - dqL_prim_dy_n(2)%vf(i)%sf(j, k, l) + & - dqR_prim_dy_n(2)%vf(i)%sf(j, k, l)) - - dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25d-2* & - dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) - - end do - end do - end do - end do - - if (p > 0) then - -!$acc parallel loop collapse(3) gang vector default(present) - do j = iz%beg + 1, iz%end - do l = iy%beg, iy%end - do k = ix%beg, ix%end -!$acc loop seq - do i = iv%beg, iv%end - - dqL_prim_dz_n(3)%vf(i)%sf(k, l, j) = & - (q_prim_qp%vf(i)%sf(k, l, j) - & - q_prim_qp%vf(i)%sf(k, l, j - 1))/ & - (z_cc(j) - z_cc(j - 1)) - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do j = iz%beg, iz%end - 1 - do l = iy%beg, iy%end - do k = ix%beg, ix%end -!$acc loop seq - do i = iv%beg, iv%end - - dqR_prim_dz_n(3)%vf(i)%sf(k, l, j) = & - (q_prim_qp%vf(i)%sf(k, l, j + 1) - & - q_prim_qp%vf(i)%sf(k, l, j))/ & - (z_cc(j + 1) - z_cc(j)) - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg + 1, iz%end - 1 - do k = iy%beg, iy%end - do j = ix%beg + 1, ix%end -!$acc loop seq - do i = iv%beg, iv%end - - dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = & - (dqL_prim_dz_n(3)%vf(i)%sf(j, k, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(j, k, l) + & - dqL_prim_dz_n(3)%vf(i)%sf(j - 1, k, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(j - 1, k, l)) - - dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25d-2* & - dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) - - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg + 1, iz%end - 1 - do k = iy%beg, iy%end - do j = ix%beg, ix%end - 1 -!$acc loop seq - do i = iv%beg, iv%end - - dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = & - (dqL_prim_dz_n(3)%vf(i)%sf(j + 1, k, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(j + 1, k, l) + & - dqL_prim_dz_n(3)%vf(i)%sf(j, k, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(j, k, l)) - - dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25d-2* & - dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) - - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg + 1, iz%end - 1 - do j = iy%beg + 1, iy%end - do k = ix%beg, ix%end - !$acc loop seq - do i = iv%beg, iv%end - - dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = & - (dqL_prim_dz_n(3)%vf(i)%sf(k, j, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(k, j, l) + & - dqL_prim_dz_n(3)%vf(i)%sf(k, j - 1, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(k, j - 1, l)) - - dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25d-2* & - dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) - - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg + 1, iz%end - 1 - do j = iy%beg, iy%end - 1 - do k = ix%beg, ix%end - !$acc loop seq - do i = iv%beg, iv%end - - dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = & - (dqL_prim_dz_n(3)%vf(i)%sf(k, j + 1, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(k, j + 1, l) + & - dqL_prim_dz_n(3)%vf(i)%sf(k, j, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(k, j, l)) - - dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25d-2* & - dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) - - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do j = iz%beg + 1, iz%end - do l = iy%beg + 1, iy%end - 1 - do k = ix%beg, ix%end -!$acc loop seq - do i = iv%beg, iv%end - - dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = & - (dqL_prim_dy_n(2)%vf(i)%sf(k, l, j) + & - dqR_prim_dy_n(2)%vf(i)%sf(k, l, j) + & - dqL_prim_dy_n(2)%vf(i)%sf(k, l, j - 1) + & - dqR_prim_dy_n(2)%vf(i)%sf(k, l, j - 1)) - - dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25d-2* & - dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) - - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do j = iz%beg, iz%end - 1 - do l = iy%beg + 1, iy%end - 1 - do k = ix%beg, ix%end -!$acc loop seq - do i = iv%beg, iv%end - - dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = & - (dqL_prim_dy_n(2)%vf(i)%sf(k, l, j + 1) + & - dqR_prim_dy_n(2)%vf(i)%sf(k, l, j + 1) + & - dqL_prim_dy_n(2)%vf(i)%sf(k, l, j) + & - dqR_prim_dy_n(2)%vf(i)%sf(k, l, j)) - - dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25d-2* & - dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) - - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do j = iz%beg + 1, iz%end - do l = iy%beg, iy%end - do k = ix%beg + 1, ix%end - 1 -!$acc loop seq - do i = iv%beg, iv%end - - dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = & - (dqL_prim_dx_n(1)%vf(i)%sf(k, l, j) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, l, j) + & - dqL_prim_dx_n(1)%vf(i)%sf(k, l, j - 1) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, l, j - 1)) - - dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25d-2* & - dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) - - end do - end do - end do - end do - -!$acc parallel loop collapse(3) gang vector default(present) - do j = iz%beg, iz%end - 1 - do l = iy%beg, iy%end - do k = ix%beg + 1, ix%end - 1 -!$acc loop seq - do i = iv%beg, iv%end - dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = & - (dqL_prim_dx_n(1)%vf(i)%sf(k, l, j + 1) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, l, j + 1) + & - dqL_prim_dx_n(1)%vf(i)%sf(k, l, j) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, l, j)) - - dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25d-2* & - dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) - - end do - end do - end do - end do - - do i = iv%beg, iv%end - call s_compute_fd_gradient(q_prim_qp%vf(i), & - dq_prim_dx_qp%vf(i), & - dq_prim_dy_qp%vf(i), & - dq_prim_dz_qp%vf(i), & - gm_vel_qp%vf(i)) - end do - - else - - do i = iv%beg, iv%end - call s_compute_fd_gradient(q_prim_qp%vf(i), & - dq_prim_dx_qp%vf(i), & - dq_prim_dy_qp%vf(i), & - dq_prim_dy_qp%vf(i), & - gm_vel_qp%vf(i)) - end do - - end if - - else - do i = iv%beg, iv%end - call s_compute_fd_gradient(q_prim_qp%vf(i), & - dq_prim_dx_qp%vf(i), & - dq_prim_dx_qp%vf(i), & - dq_prim_dx_qp%vf(i), & - gm_vel_qp%vf(i)) - end do - - end if - - end if - - end subroutine s_get_viscous - - !> The purpose of this procedure is to populate the buffers - !! of the conservative variables, depending on the selected - !! boundary conditions. - !! @param v_vf Scalar field for which buffers are populated - subroutine s_populate_variables_buffers(v_vf) ! --------------- - - type(scalar_field), dimension(sys_size), intent(INOUT) :: v_vf - - integer :: i, j, k !< Generic loop iterators - - ! Population of Buffers in x-direction ============================= - if (bc_x%beg <= -3) then ! Ghost-cell extrap. BC at beginning - - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(-j, 0:n, 0:p) = & - v_vf(i)%sf(0, 0:n, 0:p) - end do - end do - - elseif (bc_x%beg == -2) then ! Symmetry BC at beginning - - do j = 1, buff_size - - do i = 1, cont_idx%end - v_vf(i)%sf(-j, 0:n, 0:p) = & - v_vf(i)%sf(j - 1, 0:n, 0:p) - end do - - v_vf(mom_idx%beg)%sf(-j, 0:n, 0:p) = & - -v_vf(mom_idx%beg)%sf(j - 1, 0:n, 0:p) - - do i = mom_idx%beg + 1, sys_size - v_vf(i)%sf(-j, 0:n, 0:p) = & - v_vf(i)%sf(j - 1, 0:n, 0:p) - end do - - end do - - elseif (bc_x%beg == -1) then ! Periodic BC at beginning - - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(-j, 0:n, 0:p) = & - v_vf(i)%sf(m - (j - 1), 0:n, 0:p) - end do - end do - - else ! Processor BC at beginning - - call s_mpi_sendrecv_conservative_variables_buffers( & - v_vf, 1, -1) - - end if - - if (bc_x%end <= -3) then ! Ghost-cell extrap. BC at end - - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(m + j, 0:n, 0:p) = & - v_vf(i)%sf(m, 0:n, 0:p) - end do - end do - - elseif (bc_x%end == -2) then ! Symmetry BC at end - - do j = 1, buff_size - - do i = 1, cont_idx%end - v_vf(i)%sf(m + j, 0:n, 0:p) = & - v_vf(i)%sf(m - (j - 1), 0:n, 0:p) - end do - - v_vf(mom_idx%beg)%sf(m + j, 0:n, 0:p) = & - -v_vf(mom_idx%beg)%sf(m - (j - 1), 0:n, 0:p) - - do i = mom_idx%beg + 1, sys_size - v_vf(i)%sf(m + j, 0:n, 0:p) = & - v_vf(i)%sf(m - (j - 1), 0:n, 0:p) - end do - - end do - - elseif (bc_x%end == -1) then ! Periodic BC at end - - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(m + j, 0:n, 0:p) = & - v_vf(i)%sf(j - 1, 0:n, 0:p) - end do - end do - - else ! Processor BC at end - - call s_mpi_sendrecv_conservative_variables_buffers( & - v_vf, 1, 1) - - end if - - ! END: Population of Buffers in x-direction ======================== - - ! Population of Buffers in y-direction ============================= - - if (n == 0) then - - return - - elseif (bc_y%beg <= -3 .and. bc_y%beg /= -13) then ! Ghost-cell extrap. BC at beginning - - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(:, -j, 0:p) = & - v_vf(i)%sf(:, 0, 0:p) - end do - end do - - elseif (bc_y%beg == -13) then ! Axis BC at beginning - - do j = 1, buff_size - do k = 0, p - if (z_cc(k) < pi) then - do i = 1, mom_idx%beg - v_vf(i)%sf(:, -j, k) = & - v_vf(i)%sf(:, j - 1, k + ((p + 1)/2)) - end do - - v_vf(mom_idx%beg + 1)%sf(:, -j, k) = & - -v_vf(mom_idx%beg + 1)%sf(:, j - 1, k + ((p + 1)/2)) - - v_vf(mom_idx%end)%sf(:, -j, k) = & - -v_vf(mom_idx%end)%sf(:, j - 1, k + ((p + 1)/2)) - - do i = E_idx, sys_size - v_vf(i)%sf(:, -j, k) = & - v_vf(i)%sf(:, j - 1, k + ((p + 1)/2)) - end do - else - do i = 1, mom_idx%beg - v_vf(i)%sf(:, -j, k) = & - v_vf(i)%sf(:, j - 1, k - ((p + 1)/2)) - end do - - v_vf(mom_idx%beg + 1)%sf(:, -j, k) = & - -v_vf(mom_idx%beg + 1)%sf(:, j - 1, k - ((p + 1)/2)) - - v_vf(mom_idx%end)%sf(:, -j, k) = & - -v_vf(mom_idx%end)%sf(:, j - 1, k - ((p + 1)/2)) - - do i = E_idx, sys_size - v_vf(i)%sf(:, -j, k) = & - v_vf(i)%sf(:, j - 1, k - ((p + 1)/2)) - end do - end if - end do - end do - - elseif (bc_y%beg == -2) then ! Symmetry BC at beginning - - do j = 1, buff_size - - do i = 1, mom_idx%beg - v_vf(i)%sf(:, -j, 0:p) = & - v_vf(i)%sf(:, j - 1, 0:p) - end do - - v_vf(mom_idx%beg + 1)%sf(:, -j, 0:p) = & - -v_vf(mom_idx%beg + 1)%sf(:, j - 1, 0:p) - - do i = mom_idx%beg + 2, sys_size - v_vf(i)%sf(:, -j, 0:p) = & - v_vf(i)%sf(:, j - 1, 0:p) - end do - - end do - - elseif (bc_y%beg == -1) then ! Periodic BC at beginning - - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(:, -j, 0:p) = & - v_vf(i)%sf(:, n - (j - 1), 0:p) - end do - end do - - else ! Processor BC at beginning - - call s_mpi_sendrecv_conservative_variables_buffers( & - v_vf, 2, -1) - - end if - - if (bc_y%end <= -3) then ! Ghost-cell extrap. BC at end - - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(:, n + j, 0:p) = & - v_vf(i)%sf(:, n, 0:p) - end do - end do - - elseif (bc_y%end == -2) then ! Symmetry BC at end - - do j = 1, buff_size - - do i = 1, mom_idx%beg - v_vf(i)%sf(:, n + j, 0:p) = & - v_vf(i)%sf(:, n - (j - 1), 0:p) - end do - - v_vf(mom_idx%beg + 1)%sf(:, n + j, 0:p) = & - -v_vf(mom_idx%beg + 1)%sf(:, n - (j - 1), 0:p) - - do i = mom_idx%beg + 2, sys_size - v_vf(i)%sf(:, n + j, 0:p) = & - v_vf(i)%sf(:, n - (j - 1), 0:p) - end do - - end do - - elseif (bc_y%end == -1) then ! Periodic BC at end - - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(:, n + j, 0:p) = & - v_vf(i)%sf(:, j - 1, 0:p) - end do - end do - - else ! Processor BC at end - - call s_mpi_sendrecv_conservative_variables_buffers( & - v_vf, 2, 1) - - end if - - ! END: Population of Buffers in y-direction ======================== - - ! Population of Buffers in z-direction ============================= - - if (p == 0) then - - return - - elseif (bc_z%beg <= -3) then ! Ghost-cell extrap. BC at beginning - - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(:, :, -j) = & - v_vf(i)%sf(:, :, 0) - end do - end do - - elseif (bc_z%beg == -2) then ! Symmetry BC at beginning - - do j = 1, buff_size - - do i = 1, mom_idx%beg + 1 - v_vf(i)%sf(:, :, -j) = & - v_vf(i)%sf(:, :, j - 1) - end do - - v_vf(mom_idx%end)%sf(:, :, -j) = & - -v_vf(mom_idx%end)%sf(:, :, j - 1) - - do i = E_idx, sys_size - v_vf(i)%sf(:, :, -j) = & - v_vf(i)%sf(:, :, j - 1) - end do - - end do - - elseif (bc_z%beg == -1) then ! Periodic BC at beginning - - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(:, :, -j) = & - v_vf(i)%sf(:, :, p - (j - 1)) - end do - end do + if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids + rho = rho + alpha_rho(i) + gamma = gamma + alpha(i)*gammas(i) + pi_inf = pi_inf + alpha(i)*pi_infs(i) + end do + else if ((model_eqns == 2) .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids - 1 + rho = rho + alpha_rho(i) + gamma = gamma + alpha(i)*gammas(i) + pi_inf = pi_inf + alpha(i)*pi_infs(i) + end do + else + rho = alpha_rho(1) + gamma = gammas(1) + pi_inf = pi_infs(1) + end if + else + rho = 0d0 + gamma = 0d0 + pi_inf = 0d0 - else ! Processor BC at beginning + sum_alpha = 0d0 - call s_mpi_sendrecv_conservative_variables_buffers( & - v_vf, 3, -1) + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + alpha_rho(i) = max(0d0, alpha_rho(i)) + alpha(i) = min(max(0d0, alpha(i)), 1d0) + sum_alpha = sum_alpha + alpha(i) + end do - end if + alpha = alpha/max(sum_alpha, sgm_eps) - if (bc_z%end <= -3) then ! Ghost-cell extrap. BC at end + end if - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(:, :, p + j) = & - v_vf(i)%sf(:, :, p) - end do - end do + !$acc loop seq + do i = 1, num_fluids + rho = rho + alpha_rho(i) + gamma = gamma + alpha(i)*gammas(i) + pi_inf = pi_inf + alpha(i)*pi_infs(i) + end do - elseif (bc_z%end == -2) then ! Symmetry BC at end + if (any(Re_size > 0)) then + !$acc loop seq + do i = 1, 2 + Re(i) = dflt_real - do j = 1, buff_size + if (Re_size(i) > 0) Re(i) = 0d0 + !$acc loop seq + do q = 1, Re_size(i) + Re(i) = alpha(Re_idx(i, q))/Res(i, q) & + + Re(i) + end do - do i = 1, mom_idx%beg + 1 - v_vf(i)%sf(:, :, p + j) = & - v_vf(i)%sf(:, :, p - (j - 1)) - end do + Re(i) = 1d0/max(Re(i), sgm_eps) - v_vf(mom_idx%end)%sf(:, :, p + j) = & - -v_vf(mom_idx%end)%sf(:, :, p - (j - 1)) + end do + end if + end if - do i = E_idx, sys_size - v_vf(i)%sf(:, :, p + j) = & - v_vf(i)%sf(:, :, p - (j - 1)) - end do + dyn_pres = 0d0 - end do + !$acc loop seq + do i = momxb, momxe + dyn_pres = dyn_pres + 5d-1*q_cons_vf(i)%sf(j, k, l)* & + q_cons_vf(i)%sf(j, k, l)/max(rho, sgm_eps) + end do - elseif (bc_z%end == -1) then ! Periodic BC at end + pres_relax = (q_cons_vf(E_idx)%sf(j, k, l) - dyn_pres - pi_inf)/gamma - do i = 1, sys_size - do j = 1, buff_size - v_vf(i)%sf(:, :, p + j) = & - v_vf(i)%sf(:, :, j - 1) + !$acc loop seq + do i = 1, num_fluids + q_cons_vf(i + intxb - 1)%sf(j, k, l) = & + q_cons_vf(i + advxb - 1)%sf(j, k, l)* & + (gammas(i)*pres_relax + pi_infs(i)) + end do + ! ================================================================== end do end do + end do - else ! Processor BC at end - - call s_mpi_sendrecv_conservative_variables_buffers( & - v_vf, 3, 1) - - end if - - ! END: Population of Buffers in z-direction ======================== + end subroutine s_pressure_relaxation_procedure ! ----------------------- - end subroutine s_populate_variables_buffers ! ------------- !> The purpose of this procedure is to populate the buffers !! of the conservative variables, depending on the selected @@ -5027,68 +2484,12 @@ end subroutine s_populate_conservative_variables_buffers ! ------------- !! @param vR_qp Right WENO-reconstructed, cell-boundary values including !! the values at the quadrature points, of the cell-average variables !! @param norm_dir Splitting coordinate direction - subroutine s_reconstruct_cell_boundary_values_alt(v_vf, vL_x_flat, vL_y_flat, vL_z_flat, vR_x_flat, vR_y_flat, vR_z_flat, & ! - + subroutine s_reconstruct_cell_boundary_values(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, & ! - norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(IN) :: v_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: vL_x_flat, vL_y_flat, vL_z_flat, vR_x_flat, vR_y_flat, vR_z_flat - - integer, intent(IN) :: norm_dir - - integer :: weno_dir !< Coordinate direction of the WENO reconstruction - - integer :: i, j, k, l - ! Reconstruction in s1-direction =================================== - - if (norm_dir == 1) then - is1 = ix; is2 = iy; is3 = iz - weno_dir = 1; is1%beg = is1%beg + weno_polyn - is1%end = is1%end - weno_polyn - - elseif (norm_dir == 2) then - is1 = iy; is2 = ix; is3 = iz - weno_dir = 2; is1%beg = is1%beg + weno_polyn - is1%end = is1%end - weno_polyn - - else - is1 = iz; is2 = iy; is3 = ix - weno_dir = 3; is1%beg = is1%beg + weno_polyn - is1%end = is1%end - weno_polyn - - end if - - if (n > 0) then - if (p > 0) then - - call s_weno_alt(v_vf(iv%beg:iv%end), & - vL_x_flat(:, :, :, iv%beg:iv%end), vL_y_flat(:, :, :, iv%beg:iv%end), vL_z_flat(:, :, :, iv%beg:iv%end), vR_x_flat(:, :, :, iv%beg:iv%end), vR_y_flat(:, :, :, iv%beg:iv%end), vR_z_flat(:, :, :, iv%beg:iv%end), & - norm_dir, weno_dir, & - is1, is2, is3) - else - call s_weno_alt(v_vf(iv%beg:iv%end), & - vL_x_flat(:, :, :, iv%beg:iv%end), vL_y_flat(:, :, :, iv%beg:iv%end), vL_z_flat(:, :, :, :), vR_x_flat(:, :, :, iv%beg:iv%end), vR_y_flat(:, :, :, iv%beg:iv%end), vR_z_flat(:, :, :, :), & - norm_dir, weno_dir, & - is1, is2, is3) - end if - else - - call s_weno_alt(v_vf(iv%beg:iv%end), & - vL_x_flat(:, :, :, iv%beg:iv%end), vL_y_flat(:, :, :, :), vL_z_flat(:, :, :, :), vR_x_flat(:, :, :, iv%beg:iv%end), vR_y_flat(:, :, :, :), vR_z_flat(:, :, :, :), & - norm_dir, weno_dir, & - is1, is2, is3) - end if - - ! ================================================================== - end subroutine s_reconstruct_cell_boundary_values_alt ! -------------------- - - subroutine s_reconstruct_cell_boundary_values_visc(v_vf, vL_x_flat, vL_y_flat, vL_z_flat, vR_x_flat, vR_y_flat, vR_z_flat, & ! - - norm_dir, vL_prim_vf, vR_prim_vf) - - type(scalar_field), dimension(iv%beg:iv%end), intent(IN) :: v_vf - type(scalar_field), dimension(iv%beg:iv%end), intent(INOUT) :: vL_prim_vf, vR_prim_vf - - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: vL_x_flat, vL_y_flat, vL_z_flat, vR_x_flat, vR_y_flat, vR_z_flat + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: vL_x, vL_y, vL_z, vR_x, vR_y, vR_z integer, intent(IN) :: norm_dir @@ -5114,82 +2515,37 @@ subroutine s_reconstruct_cell_boundary_values_visc(v_vf, vL_x_flat, vL_y_flat, v end if - !$acc update device(is1, is2, is3, iv) - if (n > 0) then if (p > 0) then - call s_weno_alt(v_vf(iv%beg:iv%end), & - vL_x_flat(:, :, :, iv%beg:iv%end), vL_y_flat(:, :, :, iv%beg:iv%end), vL_z_flat(:, :, :, iv%beg:iv%end), vR_x_flat(:, :, :, iv%beg:iv%end), vR_y_flat(:, :, :, iv%beg:iv%end), vR_z_flat(:, :, :, iv%beg:iv%end), & + call s_weno(v_vf(iv%beg:iv%end), & + vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, iv%beg:iv%end), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, iv%beg:iv%end), & norm_dir, weno_dir, & is1, is2, is3) else - call s_weno_alt(v_vf(iv%beg:iv%end), & - vL_x_flat(:, :, :, iv%beg:iv%end), vL_y_flat(:, :, :, iv%beg:iv%end), vL_z_flat(:, :, :, :), vR_x_flat(:, :, :, iv%beg:iv%end), vR_y_flat(:, :, :, iv%beg:iv%end), vR_z_flat(:, :, :, :), & + call s_weno(v_vf(iv%beg:iv%end), & + vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, :), & norm_dir, weno_dir, & is1, is2, is3) end if else - call s_weno_alt(v_vf(iv%beg:iv%end), & - vL_x_flat(:, :, :, iv%beg:iv%end), vL_y_flat(:, :, :, :), vL_z_flat(:, :, :, :), vR_x_flat(:, :, :, iv%beg:iv%end), vR_y_flat(:, :, :, :), vR_z_flat(:, :, :, :), & + call s_weno(v_vf(iv%beg:iv%end), & + vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, :), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, :), vR_z(:, :, :, :), & norm_dir, weno_dir, & is1, is2, is3) end if - if (any(Re_size > 0)) then - if (weno_Re_flux) then - if (norm_dir == 2) then -!$acc parallel loop collapse(4) gang vector default(present) - do i = iv%beg, iv%end - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - vL_prim_vf(i)%sf(k, j, l) = vL_y_flat(j, k, l, i) - vR_prim_vf(i)%sf(k, j, l) = vR_y_flat(j, k, l, i) - end do - end do - end do - end do - elseif (norm_dir == 3) then -!$acc parallel loop collapse(4) gang vector default(present) - do i = iv%beg, iv%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - vL_prim_vf(i)%sf(l, k, j) = vL_z_flat(j, k, l, i) - vR_prim_vf(i)%sf(l, k, j) = vR_z_flat(j, k, l, i) - end do - end do - end do - end do - elseif (norm_dir == 1) then -!$acc parallel loop collapse(4) gang vector default(present) - do i = iv%beg, iv%end - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - vL_prim_vf(i)%sf(j, k, l) = vL_x_flat(j, k, l, i) - vR_prim_vf(i)%sf(j, k, l) = vR_x_flat(j, k, l, i) - end do - end do - end do - end do - end if - end if - end if - ! ================================================================== + end subroutine s_reconstruct_cell_boundary_values ! -------------------- - end subroutine s_reconstruct_cell_boundary_values_visc ! -------------------- - -subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x_flat, vL_y_flat, vL_z_flat, vR_x_flat, vR_y_flat, vR_z_flat, & ! - +subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, & ! - norm_dir, vL_prim_vf, vR_prim_vf) type(scalar_field), dimension(iv%beg:iv%end), intent(IN) :: v_vf type(scalar_field), dimension(iv%beg:iv%end), intent(INOUT) :: vL_prim_vf, vR_prim_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, iv%beg:), intent(INOUT) :: vL_x_flat, vL_y_flat, vL_z_flat, vR_x_flat, vR_y_flat, vR_z_flat + real(kind(0d0)), dimension(startx:, starty:, startz:, iv%beg:), intent(INOUT) :: vL_x, vL_y, vL_z, vR_x, vR_y, vR_z integer, intent(IN) :: norm_dir @@ -5220,20 +2576,20 @@ subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x_flat, vL_y_f if (n > 0) then if (p > 0) then - call s_weno_alt(v_vf(iv%beg:iv%end), & - vL_x_flat(:, :, :, iv%beg:iv%end), vL_y_flat(:, :, :, iv%beg:iv%end), vL_z_flat(:, :, :, iv%beg:iv%end), vR_x_flat(:, :, :, iv%beg:iv%end), vR_y_flat(:, :, :, iv%beg:iv%end), vR_z_flat(:, :, :, iv%beg:iv%end), & + call s_weno(v_vf(iv%beg:iv%end), & + vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, iv%beg:iv%end), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, iv%beg:iv%end), & norm_dir, weno_dir, & is1, is2, is3) else - call s_weno_alt(v_vf(iv%beg:iv%end), & - vL_x_flat(:, :, :, iv%beg:iv%end), vL_y_flat(:, :, :, iv%beg:iv%end), vL_z_flat(:, :, :, :), vR_x_flat(:, :, :, iv%beg:iv%end), vR_y_flat(:, :, :, iv%beg:iv%end), vR_z_flat(:, :, :, :), & + call s_weno(v_vf(iv%beg:iv%end), & + vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, :), & norm_dir, weno_dir, & is1, is2, is3) end if else - call s_weno_alt(v_vf(iv%beg:iv%end), & - vL_x_flat(:, :, :, iv%beg:iv%end), vL_y_flat(:, :, :, :), vL_z_flat(:, :, :, :), vR_x_flat(:, :, :, iv%beg:iv%end), vR_y_flat(:, :, :, :), vR_z_flat(:, :, :, :), & + call s_weno(v_vf(iv%beg:iv%end), & + vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, :), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, :), vR_z(:, :, :, :), & norm_dir, weno_dir, & is1, is2, is3) end if @@ -5246,8 +2602,8 @@ subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x_flat, vL_y_f do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end - vL_prim_vf(i)%sf(k, j, l) = vL_y_flat(j, k, l, i) - vR_prim_vf(i)%sf(k, j, l) = vR_y_flat(j, k, l, i) + vL_prim_vf(i)%sf(k, j, l) = vL_y(j, k, l, i) + vR_prim_vf(i)%sf(k, j, l) = vR_y(j, k, l, i) end do end do end do @@ -5258,8 +2614,8 @@ subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x_flat, vL_y_f do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end - vL_prim_vf(i)%sf(l, k, j) = vL_z_flat(j, k, l, i) - vR_prim_vf(i)%sf(l, k, j) = vR_z_flat(j, k, l, i) + vL_prim_vf(i)%sf(l, k, j) = vL_z(j, k, l, i) + vR_prim_vf(i)%sf(l, k, j) = vR_z(j, k, l, i) end do end do end do @@ -5270,8 +2626,8 @@ subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x_flat, vL_y_f do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end - vL_prim_vf(i)%sf(j, k, l) = vL_x_flat(j, k, l, i) - vR_prim_vf(i)%sf(j, k, l) = vR_x_flat(j, k, l, i) + vL_prim_vf(i)%sf(j, k, l) = vL_x(j, k, l, i) + vR_prim_vf(i)%sf(j, k, l) = vR_x(j, k, l, i) end do end do end do @@ -5284,153 +2640,6 @@ subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x_flat, vL_y_f end subroutine s_reconstruct_cell_boundary_values_visc_deriv ! -------------------- - subroutine s_reconstruct_cell_boundary_values(v_vf, vL_qp, vR_qp, & ! - - norm_dir) - - type(scalar_field), dimension(iv%beg:iv%end), intent(IN) :: v_vf - - type(vector_field), intent(INOUT) :: vL_qp, vR_qp - - integer, intent(IN) :: norm_dir - - integer :: weno_dir !< Coordinate direction of the WENO reconstruction - !< Indical bounds in the s1-, s2- and s3-directions - - ! Reconstruction in s1-direction =================================== - - if (norm_dir == 1) then - is1 = ix; is2 = iy; is3 = iz - weno_dir = 1; is1%beg = is1%beg + weno_polyn - is1%end = is1%end - weno_polyn - elseif (norm_dir == 2) then - is1 = iy; is2 = ix; is3 = iz - weno_dir = 2; is1%beg = is1%beg + weno_polyn - is1%end = is1%end - weno_polyn - else - is1 = iz; is2 = iy; is3 = ix - weno_dir = 3; is1%beg = is1%beg + weno_polyn - is1%end = is1%end - weno_polyn - end if - - ! ================================================================== - - end subroutine s_reconstruct_cell_boundary_values ! -------------------- - - !> The purpose of this subroutine is to employ the inputted - !! left and right cell-boundary integral-averaged variables - !! to compute the relevant cell-average first-order spatial - !! derivatives in the x-, y- or z-direction by means of the - !! scalar divergence theorem. - !! @param vL_vf Left cell-boundary integral averages - !! @param vR_vf Right cell-boundary integral averages - !! @param dv_ds_vf Cell-average first-order spatial derivatives - !! @param norm_dir Splitting coordinate direction - subroutine s_apply_scalar_divergence_theorem(vL_vf, vR_vf, & ! -------- - dv_ds_vf, & - norm_dir) - - type(scalar_field), & - dimension(iv%beg:iv%end), & - intent(IN) :: vL_vf, vR_vf - - type(scalar_field), & - dimension(iv%beg:iv%end), & - intent(INOUT) :: dv_ds_vf - - integer, intent(IN) :: norm_dir - - integer :: i, j, k, l !< Generic loop iterators - - !$acc update device(ix, iy, iz, iv) - - ! First-Order Spatial Derivatives in x-direction =================== - if (norm_dir == 1) then - - ! A general application of the scalar divergence theorem that - ! utilizes the left and right cell-boundary integral-averages, - ! inside each cell, or an arithmetic mean of these two at the - ! cell-boundaries, to calculate the cell-averaged first-order - ! spatial derivatives inside the cell. - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg + 1, ix%end - 1 -!$acc loop seq - do i = iv%beg, iv%end - - dv_ds_vf(i)%sf(j, k, l) = & - 1d0/dx(j) & - *( & - vR_vf(i)%sf(j, k, l) & - - vL_vf(i)%sf(j, k, l) & - ) - end do - end do - end do - end do - - ! END: First-Order Spatial Derivatives in x-direction ============== - - ! First-Order Spatial Derivatives in y-direction =================== - elseif (norm_dir == 2) then - - ! A general application of the scalar divergence theorem that - ! utilizes the left and right cell-boundary integral-averages, - ! inside each cell, or an arithmetic mean of these two at the - ! cell-boundaries, to calculate the cell-averaged first-order - ! spatial derivatives inside the cell. - -!$acc parallel loop collapse(3) gang vector default(present) - - do l = iz%beg, iz%end - do k = iy%beg + 1, iy%end - 1 - do j = ix%beg, ix%end -!$acc loop seq - do i = iv%beg, iv%end - dv_ds_vf(i)%sf(j, k, l) = & - 1d0/dy(k) & - *( & - vR_vf(i)%sf(j, k, l) & - - vL_vf(i)%sf(j, k, l) & - ) - end do - end do - end do - end do - - ! END: First-Order Spatial Derivatives in y-direction ============== - - ! First-Order Spatial Derivatives in z-direction =================== - else - - ! A general application of the scalar divergence theorem that - ! utilizes the left and right cell-boundary integral-averages, - ! inside each cell, or an arithmetic mean of these two at the - ! cell-boundaries, to calculate the cell-averaged first-order - ! spatial derivatives inside the cell. - -!$acc parallel loop collapse(3) gang vector default(present) - do l = iz%beg + 1, iz%end - 1 - do k = iy%beg, iy%end - do j = ix%beg, ix%end -!$acc loop seq - do i = iv%beg, iv%end - dv_ds_vf(i)%sf(j, k, l) = & - 1d0/dz(l) & - *( & - vR_vf(i)%sf(j, k, l) & - - vL_vf(i)%sf(j, k, l) & - ) - end do - end do - end do - end do - - end if - ! END: First-Order Spatial Derivatives in z-direction ============== - - end subroutine s_apply_scalar_divergence_theorem ! --------------------- !> Module deallocation and/or disassociation procedures subroutine s_finalize_rhs_module() ! ----------------------------------- @@ -5454,25 +2663,25 @@ subroutine s_finalize_rhs_module() ! ----------------------------------- deallocate (q_cons_qp%vf, q_prim_qp%vf) - deallocate (qL_rsx_vf_flat, qR_rsx_vf_flat) + deallocate (qL_rsx_vf, qR_rsx_vf) if (n > 0) then - deallocate (qL_rsy_vf_flat, qR_rsy_vf_flat) + deallocate (qL_rsy_vf, qR_rsy_vf) end if if (p > 0) then - deallocate (qL_rsz_vf_flat, qR_rsz_vf_flat) + deallocate (qL_rsz_vf, qR_rsz_vf) end if if (weno_Re_flux) then - deallocate (dqL_rsx_vf_flat, dqR_rsx_vf_flat) + deallocate (dqL_rsx_vf, dqR_rsx_vf) if (n > 0) then - deallocate (dqL_rsy_vf_flat, dqR_rsy_vf_flat) + deallocate (dqL_rsy_vf, dqR_rsy_vf) end if if (p > 0) then - deallocate (dqL_rsz_vf_flat, dqR_rsz_vf_flat) + deallocate (dqL_rsz_vf, dqR_rsz_vf) end if end if diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 98bba96834..1492f37383 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -73,11 +73,11 @@ module m_riemann_solvers !! @param iy Index bounds in the y-dir !! @param iz Index bounds in the z-dir !! @param q_prim_vf Cell-averaged primitive variables - subroutine s_abstract_riemann_solver(qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & + subroutine s_abstract_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & - qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, dqR_prim_dx_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & dqR_prim_dy_vf, & dqR_prim_dz_vf, & qR_prim_vf, & @@ -88,7 +88,7 @@ module m_riemann_solvers import :: scalar_field, int_bounds_info, sys_size, startx, starty, startz - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(INOUT) :: qL_prim_vf, qR_prim_vf @@ -175,61 +175,22 @@ module m_riemann_solvers end interface ! ============================================================ - type(scalar_field), allocatable, dimension(:) :: qL_prim_rs_vf - type(scalar_field), allocatable, dimension(:) :: qR_prim_rs_vf - type(scalar_field), allocatable, dimension(:) :: flux_rs_vf, flux_src_rs_vf - type(scalar_field), allocatable, dimension(:) :: flux_gsrc_rs_vf !< - type(scalar_field), allocatable, dimension(:) :: vel_src_rs_vf - - !> The left (L) and right (R) WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables that define the left and right states of - !! the Riemann problem. Variables qK_prim_rs_vf, K = L or R, are obtained by - !! reshaping (RS) qK_prim_vf in a coordinate direction that is normal to the - !! cell-boundaries along which the fluxes are to be determined. - !> @{ - type(scalar_field), allocatable, dimension(:) :: qL_prim_rsx_vf - type(scalar_field), allocatable, dimension(:) :: qR_prim_rsx_vf - - type(scalar_field), allocatable, dimension(:) :: qL_prim_rsy_vf - type(scalar_field), allocatable, dimension(:) :: qR_prim_rsy_vf - - type(scalar_field), allocatable, dimension(:) :: qL_prim_rsz_vf - type(scalar_field), allocatable, dimension(:) :: qR_prim_rsz_vf - - !> @} - - !> @} - - type(scalar_field), allocatable, dimension(:) :: flux_gsrc_rsx_vf !< - type(scalar_field), allocatable, dimension(:) :: flux_gsrc_rsy_vf !< - type(scalar_field), allocatable, dimension(:) :: flux_gsrc_rsz_vf !< - - !! The cell-boundary values of the geometrical source flux that are computed - !! through the chosen Riemann problem solver by using the left and right - !! states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. - ! The cell-boundary values of the velocity. vel_src_rs_vf is determined as - ! part of Riemann problem solution and is used to evaluate the source flux. - type(scalar_field), allocatable, dimension(:) :: vel_src_rsx_vf - type(scalar_field), allocatable, dimension(:) :: vel_src_rsy_vf - type(scalar_field), allocatable, dimension(:) :: vel_src_rsz_vf - - !> @} !> The cell-boundary values of the fluxes (src - source) that are computed !! through the chosen Riemann problem solver, and the direct evaluation of !! source terms, by using the left and right states given in qK_prim_rs_vf, !! dqK_prim_ds_vf and kappaK_rs_vf, where ds = dx, dy or dz. !> @{ - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsx_vf_flat, flux_src_rsx_vf_flat - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsy_vf_flat, flux_src_rsy_vf_flat - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsz_vf_flat, flux_src_rsz_vf_flat + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsx_vf, flux_src_rsx_vf + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsy_vf, flux_src_rsy_vf + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsz_vf, flux_src_rsz_vf !> @} - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsx_vf_flat !< - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsy_vf_flat !< - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsz_vf_flat !< + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsx_vf !< + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsy_vf !< + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsz_vf !< !! The cell-boundary values of the geometrical source flux that are computed !! through the chosen Riemann problem solver by using the left and right @@ -237,13 +198,13 @@ module m_riemann_solvers ! The cell-boundary values of the velocity. vel_src_rs_vf is determined as ! part of Riemann problem solution and is used to evaluate the source flux. - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: vel_src_rsx_vf_flat - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: vel_src_rsy_vf_flat - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: vel_src_rsz_vf_flat + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: vel_src_rsx_vf + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: vel_src_rsy_vf + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: vel_src_rsz_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: mom_sp_rsx_vf_flat - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: mom_sp_rsy_vf_flat - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: mom_sp_rsz_vf_flat + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: mom_sp_rsx_vf + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: mom_sp_rsy_vf + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: mom_sp_rsz_vf !> @name Left and right, WENO-reconstructed, cell-boundary values of cell-average !! partial densities, density, velocity, pressure, internal energy, energy, enthalpy, volume @@ -334,14 +295,10 @@ module m_riemann_solvers type(scalar_field), allocatable, dimension(:) :: alpha_avg_rs_vf real(kind(0d0)) :: gamma_avg real(kind(0d0)) :: c_avg - type(scalar_field), allocatable, dimension(:) :: Re_avg_rs_vf - type(scalar_field), allocatable, dimension(:) :: Re_avg_rsx_vf - type(scalar_field), allocatable, dimension(:) :: Re_avg_rsy_vf - type(scalar_field), allocatable, dimension(:) :: Re_avg_rsz_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: Re_avg_rsx_vf_flat - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: Re_avg_rsy_vf_flat - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: Re_avg_rsz_vf_flat -!$acc declare create(rho_avg, vel_avg, H_avg, alpha_avg_rs_vf, gamma_avg, c_avg, Re_avg_rs_vf, Re_avg_rsx_vf, Re_avg_rsy_vf, Re_avg_rsz_vf, Re_avg_rsx_vf_flat, Re_avg_rsy_vf_flat, Re_avg_rsz_vf_flat) + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: Re_avg_rsx_vf + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: Re_avg_rsy_vf + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: Re_avg_rsz_vf +!$acc declare create(rho_avg, vel_avg, H_avg, alpha_avg_rs_vf, gamma_avg, c_avg, Re_avg_rsx_vf, Re_avg_rsy_vf, Re_avg_rsz_vf) !> @} !> @name Left, right and star (S) region wave speeds @@ -393,39 +350,28 @@ module m_riemann_solvers type(int_bounds_info) :: is1, is2, is3 type(int_bounds_info) :: isx, isy, isz !> @} -!$acc declare create(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & -!$acc is1, is2, is3, isx, isy, isz, vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf, & -!$acc flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf) +!$acc declare create( & +!$acc is1, is2, is3, isx, isy, isz) !$acc declare create(& -!$acc flux_rsx_vf_flat, flux_src_rsx_vf_flat, flux_rsy_vf_flat, flux_src_rsy_vf_flat, flux_rsz_vf_flat, flux_src_rsz_vf_flat, vel_src_rsx_vf_flat, vel_src_rsy_vf_flat, vel_src_rsz_vf_flat, & -!$acc flux_gsrc_rsx_vf_flat, flux_gsrc_rsy_vf_flat, flux_gsrc_rsz_vf_flat, mom_sp_rsx_vf_flat, mom_sp_rsy_vf_flat, mom_sp_rsz_vf_flat) - - integer :: momxb, momxe - integer :: contxb, contxe - integer :: advxb, advxe - integer :: bubxb, bubxe - integer :: intxb, intxe - integer :: strxb, strxe - -!$acc declare create(momxb, momxe, contxb, contxe, advxb, advxe, bubxb, bubxe, intxb, intxe, strxb, strxe) +!$acc flux_rsx_vf, flux_src_rsx_vf, flux_rsy_vf, flux_src_rsy_vf, flux_rsz_vf, flux_src_rsz_vf, vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf, & +!$acc flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf, mom_sp_rsx_vf, mom_sp_rsy_vf, mom_sp_rsz_vf) - real(kind(0d0)), allocatable, dimension(:) :: gammas, pi_infs, Gs -!$acc declare create(gammas, pi_infs, Gs) + + real(kind(0d0)), allocatable, dimension(:) :: Gs +!$acc declare create( Gs) - integer, allocatable, dimension(:) :: rs, vs, ps, ms -!$acc declare create(rs, vs, ps, ms) real(kind(0d0)), allocatable, dimension(:, :) :: Res !$acc declare create(Res) contains - subroutine s_hll_riemann_solver(qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & ! ------- + subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & ! ------- dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & - qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, dqR_prim_dx_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & dqR_prim_dy_vf, & dqR_prim_dz_vf, & qR_prim_vf, & @@ -434,7 +380,7 @@ contains flux_gsrc_vf, & norm_dir, ix, iy, iz) - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(INOUT) :: qL_prim_vf, qR_prim_vf @@ -491,11 +437,11 @@ contains ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & - qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, dqR_prim_dx_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & dqR_prim_dy_vf, & dqR_prim_dz_vf, & qR_prim_vf, & @@ -517,14 +463,14 @@ contains do j = is1%beg, is1%end !$acc loop seq do i = 1, contxe - alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) - alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) + alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) end do !$acc loop seq do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, contxe + i) + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) end do vel_L_rms = 0d0; vel_R_rms = 0d0 @@ -537,12 +483,12 @@ contains !$acc loop seq do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i) + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do - pres_L = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx) + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 @@ -628,8 +574,8 @@ contains if (hypoelasticity) then !$acc loop seq do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, strxb - 1 + i) + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) end do G_L = 0d0 @@ -722,11 +668,11 @@ contains !$acc loop seq do i = 1, num_fluids - c_L = c_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & - (qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) + c_L = c_L + qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & + (qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) - c_R = c_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & - (qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) + c_R = c_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & + (qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) end do c_L = c_L/rho_L @@ -770,7 +716,7 @@ contains if (any(Re_size > 0)) then !$acc loop seq do i = 1, 2 - Re_avg_rs${XYZ}$_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do end if @@ -834,7 +780,7 @@ contains ! Mass !$acc loop seq do i = 1, contxe - flux_rs${XYZ}$_vf_flat(j, k, l, i) = & + flux_rs${XYZ}$_vf(j, k, l, i) = & (s_M*alpha_rho_R(i)*vel_R(dir_idx(1)) & - s_P*alpha_rho_L(i)*vel_L(dir_idx(1)) & + s_M*s_P*(alpha_rho_L(i) & @@ -846,7 +792,7 @@ contains if (bubbles) then !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf_flat(j, k, l, contxe + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & (s_M*(rho_R*vel_R(dir_idx(1)) & *vel_R(dir_idx(i)) & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & @@ -860,7 +806,7 @@ contains else if (hypoelasticity) then !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf_flat(j, k, l, contxe + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & (s_M*(rho_R*vel_R(dir_idx(1)) & *vel_R(dir_idx(i)) & + dir_flg(dir_idx(i))*pres_R & @@ -876,7 +822,7 @@ contains else !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf_flat(j, k, l, contxe + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & (s_M*(rho_R*vel_R(dir_idx(1)) & *vel_R(dir_idx(i)) & + dir_flg(dir_idx(i))*pres_R) & @@ -891,7 +837,7 @@ contains ! Energy if (bubbles) then - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = & + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & + s_M*s_P*(E_L - E_R)) & @@ -899,7 +845,7 @@ contains else if (hypoelasticity) then !TODO: simplify this so it's not split into 3 if (num_dims == 1) then - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = & + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1)))) & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & @@ -907,7 +853,7 @@ contains + s_M*s_P*(E_L - E_R)) & /(s_M - s_P) else if (num_dims == 2) then - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = & + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2)))) & @@ -917,7 +863,7 @@ contains + s_M*s_P*(E_L - E_R)) & /(s_M - s_P) else if (num_dims == 3) then - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = & + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2))) & @@ -930,7 +876,7 @@ contains /(s_M - s_P) end if else - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = & + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & + s_M*s_P*(E_L - E_R)) & @@ -940,7 +886,7 @@ contains ! Elastic Stresses if (hypoelasticity) then do i = 1, strxe - strxb + 1 !TODO: this indexing may be slow - flux_rs${XYZ}$_vf_flat(j, k, l, strxb - 1 + i) = & + flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & (s_M*(rho_R*vel_R(dir_idx(1)) & *tau_e_R(i)) & - s_P*(rho_L*vel_L(dir_idx(1)) & @@ -954,20 +900,20 @@ contains ! Advection !$acc loop seq do i = advxb, advxe - flux_rs${XYZ}$_vf_flat(j, k, l, i) = & - (qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) & - - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i)) & + flux_rs${XYZ}$_vf(j, k, l, i) = & + (qL_prim_rs${XYZ}$_vf(j, k, l, i) & + - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) & *s_M*s_P/(s_M - s_P) - flux_src_rs${XYZ}$_vf_flat(j, k, l, i) = & - (s_M*qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) & - - s_P*qL_prim_rs${XYZ}$_vf_flat(j, k, l, i)) & + flux_src_rs${XYZ}$_vf(j, k, l, i) = & + (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i)) & /(s_M - s_P) end do ! Div(U)? !$acc loop seq do i = 1, num_dims - vel_src_rs${XYZ}$_vf_flat(j, k, l, dir_idx(i)) = & + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & (xi_M*(rho_L*vel_L(dir_idx(i))* & (s_L - vel_L(dir_idx(1))) - & pres_L*dir_flg(dir_idx(i))) - & @@ -981,7 +927,7 @@ contains if (bubbles) then ! From HLLC: Kills mass transport @ bubble gas density if (num_fluids > 1) then - flux_rs${XYZ}$_vf_flat(j, k, l, contxe) = 0d0 + flux_rs${XYZ}$_vf(j, k, l, contxe) = 0d0 end if end if end do @@ -1056,11 +1002,11 @@ contains !! @param iz Index bounds in the z-dir !! @param q_prim_vf Cell-averaged primitive variables - subroutine s_hllc_riemann_solver(qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & ! ------ + subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & ! ------ dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & - qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, dqR_prim_dx_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & dqR_prim_dy_vf, & dqR_prim_dz_vf, & qR_prim_vf, & @@ -1069,7 +1015,7 @@ contains flux_gsrc_vf, & norm_dir, ix, iy, iz) - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(INOUT) :: qL_prim_vf, qR_prim_vf @@ -1129,17 +1075,18 @@ contains real(kind(0d0)) :: blkmod1, blkmod2 real(kind(0d0)) :: rho_Star, E_Star, p_Star, p_K_Star real(kind(0d0)) :: pres_SL, pres_SR, Ms_L, Ms_R + real(kind(0d0)) :: start, finish integer :: i, j, k, l, q !< Generic loop iterators integer :: idx1, idxi ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & - qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, dqR_prim_dx_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & dqR_prim_dy_vf, & dqR_prim_dz_vf, & qR_prim_vf, & @@ -1168,14 +1115,14 @@ contains !$acc loop seq do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, contxe + i) + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do - pres_L = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx) + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 @@ -1191,38 +1138,38 @@ contains if (mpp_lim) then !$acc loop seq do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) = max(0d0, qL_prim_rs${XYZ}$_vf_flat(j, k, l, i)) - qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)), 1d0) - alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i) + qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0d0, qL_prim_rs${XYZ}$_vf(j, k, l, i)) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1d0) + alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) end do !$acc loop seq do i = 1, num_fluids - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) = max(0d0, qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i)) - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i) = min(max(0d0, qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)), 1d0) - alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0d0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0d0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1d0) + alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if !$acc loop seq do i = 1, num_fluids - rho_L = rho_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)*pi_infs(i) + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - rho_R = rho_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) end do if (any(Re_size > 0)) then @@ -1234,7 +1181,7 @@ contains !$acc loop seq do q = 1, Re_size(i) - Re_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) end do @@ -1250,7 +1197,7 @@ contains !$acc loop seq do q = 1, Re_size(i) - Re_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) end do @@ -1312,25 +1259,25 @@ contains pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) - c_L = 1d0/(rho_L*(qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + 1)/blkmod1 & - + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + 2)/blkmod2)) + c_L = 1d0/(rho_L*(qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + 1)/blkmod1 & + + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) - c_R = 1d0/(rho_R*(qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 & - + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, e_idx + 2)/blkmod2)) + c_R = 1d0/(rho_R*(qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + 1)/blkmod1 & + + qR_prim_rs${XYZ}$_vf(j + 1, k, l, e_idx + 2)/blkmod2)) else c_L = 0d0 c_R = 0d0 !$acc loop seq do i = 1, num_fluids - c_L = c_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & - (qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) - c_R = c_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & - (qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) + c_L = c_L + qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & + (qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) + c_R = c_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & + (qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) end do c_L = c_L/rho_L c_R = c_R/rho_R @@ -1350,7 +1297,7 @@ contains if (any(Re_size > 0)) then !$acc loop seq do i = 1, 2 - Re_avg_rs${XYZ}$_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do end if @@ -1390,26 +1337,26 @@ contains p_Star = pres_L ! Only usefull to recalculate the radial momentum geometric source flux !$acc loop seq do i = 1, num_fluids - flux_rs${XYZ}$_vf_flat(j, k, l, i + advxb - 1) = & - qL_prim_rs${XYZ}$_vf_flat(j, k, l, i + advxb - 1)*s_S + flux_rs${XYZ}$_vf(j, k, l, i + advxb - 1) = & + qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1)*s_S - flux_rs${XYZ}$_vf_flat(j, k, l, i + contxb - 1) = & - qL_prim_rs${XYZ}$_vf_flat(j, k, l, i + contxb - 1)*vel_L(dir_idx(1)) + flux_rs${XYZ}$_vf(j, k, l, i + contxb - 1) = & + qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1)*vel_L(dir_idx(1)) - flux_rs${XYZ}$_vf_flat(j, k, l, i + intxb - 1) = & - qL_prim_rs${XYZ}$_vf_flat(j, k, l, i + advxb - 1)* & + flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = & + qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1)* & (gammas(i)*pres_L + pi_infs(i))*vel_L(dir_idx(1)) end do !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(i)) = & rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L - vel_src_rs${XYZ}$_vf_flat(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S - vel_L(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = (E_L + pres_L)*vel_L(dir_idx(1)) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_L + pres_L)*vel_L(dir_idx(1)) ! Compute right solution state else if (s_R <= 0d0) then @@ -1417,26 +1364,26 @@ contains ! Only usefull to recalculate the radial momentum geometric source flux !$acc loop seq do i = 1, num_fluids - flux_rs${XYZ}$_vf_flat(j, k, l, i + advxb - 1) = & - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i + advxb - 1)*s_S + flux_rs${XYZ}$_vf(j, k, l, i + advxb - 1) = & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)*s_S - flux_rs${XYZ}$_vf_flat(j, k, l, i + contxb - 1) = & - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i + contxb - 1)*vel_R(dir_idx(1)) + flux_rs${XYZ}$_vf(j, k, l, i + contxb - 1) = & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1)*vel_R(dir_idx(1)) - flux_rs${XYZ}$_vf_flat(j, k, l, i + intxb - 1) = & - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i + advxb - 1)* & + flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)* & (gammas(i)*pres_R + pi_infs(i))*vel_R(dir_idx(1)) end do !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(i)) = & rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*pres_R - vel_src_rs${XYZ}$_vf_flat(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S - vel_R(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = (E_R + pres_R)*vel_R(dir_idx(1)) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_R + pres_R)*vel_R(dir_idx(1)) ! Compute left star solution state else if (s_S >= 0d0) then @@ -1450,27 +1397,27 @@ contains p_K_Star = (pres_L + pi_infs(i)/(1d0 + gammas(i)))* & xi_L**(1d0/gammas(i) + 1d0) - pi_infs(i)/(1d0 + gammas(i)) - flux_rs${XYZ}$_vf_flat(j, k, l, i + advxb - 1) = & - qL_prim_rs${XYZ}$_vf_flat(j, k, l, i + advxb - 1)*s_S + flux_rs${XYZ}$_vf(j, k, l, i + advxb - 1) = & + qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1)*s_S - flux_rs${XYZ}$_vf_flat(j, k, l, i + contxb - 1) = & - qL_prim_rs${XYZ}$_vf_flat(j, k, l, i + contxb - 1)*xi_L*s_S + flux_rs${XYZ}$_vf(j, k, l, i + contxb - 1) = & + qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1)*xi_L*s_S - flux_rs${XYZ}$_vf_flat(j, k, l, i + intxb - 1) = & - qL_prim_rs${XYZ}$_vf_flat(j, k, l, i + advxb - 1)* & + flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = & + qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1)* & (gammas(i)*p_K_Star + pi_infs(i))*s_S end do !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(i)) = & rho_Star*s_S*(s_S*dir_flg(dir_idx(i)) + vel_L(dir_idx(i))* & (1d0 - dir_flg(dir_idx(i)))) + dir_flg(dir_idx(i))*p_Star - vel_src_rs${XYZ}$_vf_flat(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S*xi_L - vel_L(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = (E_Star + p_Star)*s_S + flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_Star + p_Star)*s_S ! Compute right star solution state else @@ -1487,51 +1434,51 @@ contains p_K_Star = (pres_R + pi_infs(i)/(1d0 + gammas(i)))* & xi_R**(1d0/gammas(i) + 1d0) - pi_infs(i)/(1d0 + gammas(i)) - flux_rs${XYZ}$_vf_flat(j, k, l, i + advxb - 1) = & - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i + advxb - 1)*s_S + flux_rs${XYZ}$_vf(j, k, l, i + advxb - 1) = & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)*s_S - flux_rs${XYZ}$_vf_flat(j, k, l, i + contxb - 1) = & - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i + contxb - 1)*xi_R*s_S + flux_rs${XYZ}$_vf(j, k, l, i + contxb - 1) = & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1)*xi_R*s_S - flux_rs${XYZ}$_vf_flat(j, k, l, i + intxb - 1) = & - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i + advxb - 1)* & + flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)* & (gammas(i)*p_K_Star + pi_infs(i))*s_S end do !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = rho_Star*s_S* & + flux_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(i)) = rho_Star*s_S* & (s_S*dir_flg(dir_idx(i)) + vel_R(dir_idx(i))*(1d0 - dir_flg(dir_idx(i)))) + & dir_flg(dir_idx(i))*p_Star - vel_src_rs${XYZ}$_vf_flat(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S*xi_R - vel_R(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = (E_Star + p_Star)*s_S + flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_Star + p_Star)*s_S end if - flux_src_rs${XYZ}$_vf_flat(j, k, l, advxb) = vel_src_rs${XYZ}$_vf_flat(j, k, l, dir_idx(1)) + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) ! Geometrical source flux for cylindrical coordinates if (cyl_coord .and. norm_dir == 2) then ! Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = flux_rs${XYZ}$_vf_flat(j, k, l, i) + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do !$acc loop seq do i = intxb, intxe - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = flux_rs${XYZ}$_vf_flat(j, k, l, i) + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux (substracting the pressure part) - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star ! Geometrical source of the void fraction(s) is zero !$acc loop seq do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 end do end if @@ -1547,14 +1494,14 @@ contains do j = is1%beg, is1%end !$acc loop seq do i = 1, contxe - alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) - alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) + alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) end do !$acc loop seq do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, contxe + i) + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) end do vel_L_rms = 0d0; vel_R_rms = 0d0 @@ -1566,12 +1513,12 @@ contains !$acc loop seq do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i) + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do - pres_L = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx) + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 @@ -1737,7 +1684,7 @@ contains !$acc loop seq do i = 1, contxe - flux_rs${XYZ}$_vf_flat(j, k, l, i) = & + flux_rs${XYZ}$_vf(j, k, l, i) = & xi_M*alpha_rho_L(i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*alpha_rho_R(i) & @@ -1749,7 +1696,7 @@ contains if (bubbles .neqv. .true.) then !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf_flat(j, k, l, contxe + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(i)) + & s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & @@ -1768,7 +1715,7 @@ contains ! Include p_tilde !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf_flat(j, k, l, contxe + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(i)) + & s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & @@ -1786,14 +1733,14 @@ contains end if - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = 0.d0 + flux_rs${XYZ}$_vf(j, k, l, E_idx) = 0.d0 !$acc loop seq do i = alf_idx, alf_idx !only advect the void fraction - flux_rs${XYZ}$_vf_flat(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) & + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & - + xi_P*qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do @@ -1801,20 +1748,20 @@ contains !$acc loop seq do i = 1, num_dims - vel_src_rs${XYZ}$_vf_flat(j, k, l, dir_idx(i)) = 0d0 + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0d0 !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do - flux_src_rs${XYZ}$_vf_flat(j, k, l, advxb) = vel_src_rs${XYZ}$_vf_flat(j, k, l, dir_idx(1)) + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) ! Add advection flux for bubble variables if (bubbles) then !$acc loop seq do i = bubxb, bubxe - flux_rs${XYZ}$_vf_flat(j, k, l, i) = & - xi_M*nbub_L*qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) & + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & - + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) & + + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do end if @@ -1826,10 +1773,10 @@ contains ! Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = flux_rs${XYZ}$_vf_flat(j, k, l, i) + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, contxe + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(1)) + & s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & @@ -1843,7 +1790,7 @@ contains ! Geometrical source of the void fraction(s) is zero !$acc loop seq do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 end do end if #:endif @@ -1851,9 +1798,9 @@ contains if (grid_geometry == 3) then !$acc loop seq do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 end do - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, momxb + 1) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & -xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(1)) + & s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & @@ -1864,14 +1811,15 @@ contains s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & (1d0 - dir_flg(dir_idx(1)))* & vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, momxe) = flux_rs${XYZ}$_vf_flat(j, k, l, momxb + 1) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif end do end do end do + elseif (model_eqns == 2 .and. bubbles) then - !$acc parallel loop collapse(3) gang vector default(present) private(R0_L, R0_R, V0_L, V0_R, P0_L, P0_R, pbw_L, pbw_R, vel_L, vel_R, & + !$acc parallel loop collapse(3) gang vector default(present) private(R0_L, R0_R, V0_L, V0_R, P0_L, P0_R, pbw_L, pbw_R, vel_L, vel_R, & !$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, nbub_L, nbub_R, ptilde_L, ptilde_R, vel_avg_rms) do l = is3%beg, is3%end do k = is2%beg, is2%end @@ -1881,14 +1829,14 @@ contains !$acc loop seq do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, contxe + i) + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do - pres_L = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx) + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 @@ -1897,19 +1845,19 @@ contains if (mpp_lim .and. (num_fluids > 2)) then !$acc loop seq do i = 1, num_fluids - rho_L = rho_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)*pi_infs(i) + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) end do else if (num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 - rho_L = rho_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)*pi_infs(i) + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) end do else - rho_L = qL_prim_rs${XYZ}$_vf_flat(j, k, l, 1) + rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) gamma_L = gammas(1) pi_inf_L = pi_infs(1) end if @@ -1921,19 +1869,19 @@ contains if (mpp_lim .and. (num_fluids > 2)) then !$acc loop seq do i = 1, num_fluids - rho_R = rho_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) end do else if (num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 - rho_R = rho_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) end do else - rho_R = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, 1) + rho_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, 1) gamma_R = gammas(1) pi_inf_R = pi_infs(1) end if @@ -1948,19 +1896,19 @@ contains !$acc loop seq do i = 1, nb - R0_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, rs(i)) - R0_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, rs(i)) + R0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, rs(i)) + R0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, rs(i)) - V0_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, vs(i)) - V0_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, vs(i)) + V0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, vs(i)) + V0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, vs(i)) if (.not. polytropic) then - P0_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, ps(i)) - P0_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, ps(i)) + P0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, ps(i)) + P0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, ps(i)) end if end do - !call s_comp_n_from_prim(qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + num_fluids), R0_L, nbub_L) - !call s_comp_n_from_prim(qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + num_fluids), R0_R, nbub_R) + !call s_comp_n_from_prim(qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids), R0_L, nbub_L) + !call s_comp_n_from_prim(qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids), R0_R, nbub_R) nbub_L_denom = 0d0 nbub_R_denom = 0d0 @@ -1971,8 +1919,8 @@ contains nbub_R_denom = nbub_R_denom + (R0_R(i)**3d0)*weight(i) end do - nbub_L = (3.d0/(4.d0*pi))*qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + num_fluids)/nbub_L_denom - nbub_R = (3.d0/(4.d0*pi))*qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom + nbub_L = (3.d0/(4.d0*pi))*qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)/nbub_L_denom + nbub_R = (3.d0/(4.d0*pi))*qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom !$acc loop seq do i = 1, nb @@ -1988,14 +1936,14 @@ contains end do if (qbmm) then - PbwR3Lbar = mom_sp_rs${XYZ}$_vf_flat(j, k, l, 4) - PbwR3Rbar = mom_sp_rs${XYZ}$_vf_flat(j + 1, k, l, 4) + PbwR3Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 4) + PbwR3Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 4) - R3Lbar = mom_sp_rs${XYZ}$_vf_flat(j, k, l, 1) - R3Rbar = mom_sp_rs${XYZ}$_vf_flat(j + 1, k, l, 1) + R3Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 1) + R3Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 1) - R3V2Lbar = mom_sp_rs${XYZ}$_vf_flat(j, k, l, 3) - R3V2Rbar = mom_sp_rs${XYZ}$_vf_flat(j + 1, k, l, 3) + R3V2Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 3) + R3V2Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 3) else PbwR3Lbar = 0d0 @@ -2022,17 +1970,17 @@ contains end do end if - if (qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + num_fluids) < small_alf .or. R3Lbar < small_alf) then - ptilde_L = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + num_fluids)*pres_L + if (qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids) < small_alf .or. R3Lbar < small_alf) then + ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*pres_L else - ptilde_L = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + num_fluids)*(pres_L - PbwR3Lbar/R3Lbar - & + ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*(pres_L - PbwR3Lbar/R3Lbar - & rho_L*R3V2Lbar/R3Lbar) end if - if (qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + num_fluids) < small_alf .or. R3Rbar < small_alf) then - ptilde_R = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + num_fluids)*pres_R + if (qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids) < small_alf .or. R3Rbar < small_alf) then + ptilde_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)*pres_R else - ptilde_R = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + num_fluids)*(pres_R - PbwR3Rbar/R3Rbar - & + ptilde_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)*(pres_R - PbwR3Rbar/R3Rbar - & rho_R*R3V2Rbar/R3Rbar) end if @@ -2089,13 +2037,13 @@ contains pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) - c_L = 1d0/(rho_L*(qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + 1)/blkmod1 + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + 2)/blkmod2)) + c_L = 1d0/(rho_L*(qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + 1)/blkmod1 + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) - c_R = 1d0/(rho_R*(qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + 2)/blkmod2)) + c_R = 1d0/(rho_R*(qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + 1)/blkmod1 + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + 2)/blkmod2)) else ! Sound speed for bubble mmixture to order O(\alpha) @@ -2109,11 +2057,11 @@ contains c_L = & (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/ & - (rho_L*(1d0 - qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + num_fluids))) + (rho_L*(1d0 - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids))) c_R = & (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/ & - (rho_R*(1d0 - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + num_fluids))) + (rho_R*(1d0 - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids))) end if end if @@ -2176,16 +2124,16 @@ contains !$acc loop seq do i = 1, contxe - flux_rs${XYZ}$_vf_flat(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) & + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & - + xi_P*qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do if (bubbles .and. (num_fluids > 1)) then ! Kill mass transport @ gas density - flux_rs${XYZ}$_vf_flat(j, k, l, contxe) = 0.d0 + flux_rs${XYZ}$_vf(j, k, l, contxe) = 0.d0 end if ! Momentum flux. @@ -2194,7 +2142,7 @@ contains ! Include p_tilde !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf_flat(j, k, l, contxe + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(i)) + & s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & @@ -2213,7 +2161,7 @@ contains ! Energy flux. ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = & + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & xi_M*(vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + & s_M*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & (rho_L*s_S + (pres_L - ptilde_L)/ & @@ -2227,17 +2175,17 @@ contains !$acc loop seq do i = advxb, advxe - flux_rs${XYZ}$_vf_flat(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) & + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & - + xi_P*qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims - vel_src_rs${XYZ}$_vf_flat(j, k, l, dir_idx(i)) = & + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & xi_M*(vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))* & s_M*(xi_L - 1d0)) & @@ -2248,16 +2196,16 @@ contains !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do - flux_src_rs${XYZ}$_vf_flat(j, k, l, advxb) = vel_src_rs${XYZ}$_vf_flat(j, k, l, dir_idx(1)) + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) ! Add advection flux for bubble variables !$acc loop seq do i = bubxb, bubxe - flux_rs${XYZ}$_vf_flat(j, k, l, i) = & - xi_M*nbub_L*qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) & + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & - + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) & + + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do @@ -2268,10 +2216,10 @@ contains ! Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = flux_rs${XYZ}$_vf_flat(j, k, l, i) + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, contxe + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(1)) + & s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & @@ -2285,7 +2233,7 @@ contains ! Geometrical source of the void fraction(s) is zero !$acc loop seq do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 end do end if #:endif @@ -2293,10 +2241,10 @@ contains if (grid_geometry == 3) then !$acc loop seq do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 end do - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, momxb + 1) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & -xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(1)) + & s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & @@ -2307,7 +2255,7 @@ contains s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & (1d0 - dir_flg(dir_idx(1)))* & vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, momxe) = flux_rs${XYZ}$_vf_flat(j, k, l, momxb + 1) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif @@ -2326,14 +2274,14 @@ contains vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, contxe + i) + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do - pres_L = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx) + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 @@ -2349,38 +2297,38 @@ contains if (mpp_lim) then !$acc loop seq do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) = max(0d0, qL_prim_rs${XYZ}$_vf_flat(j, k, l, i)) - qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)), 1d0) - alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i) + qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0d0, qL_prim_rs${XYZ}$_vf(j, k, l, i)) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1d0) + alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) end do !$acc loop seq do i = 1, num_fluids - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) = max(0d0, qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i)) - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i) = min(max(0d0, qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)), 1d0) - alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0d0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0d0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1d0) + alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids - qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if !$acc loop seq do i = 1, num_fluids - rho_L = rho_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + i)*pi_infs(i) + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - rho_R = rho_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) end do if (any(Re_size > 0)) then @@ -2392,7 +2340,7 @@ contains !$acc loop seq do q = 1, Re_size(i) - Re_L(i) = qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) end do @@ -2408,7 +2356,7 @@ contains !$acc loop seq do q = 1, Re_size(i) - Re_R(i) = qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) end do @@ -2477,15 +2425,15 @@ contains pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) - c_L = 1d0/(rho_L*(qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + 1)/blkmod1 & - + qL_prim_rs${XYZ}$_vf_flat(j, k, l, E_idx + 2)/blkmod2)) + c_L = 1d0/(rho_L*(qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + 1)/blkmod1 & + + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) - c_R = 1d0/(rho_R*(qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 & - + qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, e_idx + 2)/blkmod2)) + c_R = 1d0/(rho_R*(qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + 1)/blkmod1 & + + qR_prim_rs${XYZ}$_vf(j + 1, k, l, e_idx + 2)/blkmod2)) else c_L = ((H_L - 5d-1*vel_L_rms)/gamma_L) @@ -2507,7 +2455,7 @@ contains if (any(Re_size > 0)) then !$acc loop seq do i = 1, 2 - Re_avg_rs${XYZ}$_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do end if @@ -2559,10 +2507,10 @@ contains !$acc loop seq do i = 1, contxe - flux_rs${XYZ}$_vf_flat(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) & + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & *(vel_L(idx1) + s_M*(xi_L - 1d0)) & - + xi_P*qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & *(vel_R(idx1) + s_P*(xi_R - 1d0)) end do @@ -2572,7 +2520,7 @@ contains !$acc loop seq do i = 1, num_dims idxi = dir_idx(i) - flux_rs${XYZ}$_vf_flat(j, k, l, contxe + idxi) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & xi_M*(rho_L*(vel_L(idx1)* & vel_L(idxi) + & s_M*(xi_L*(dir_flg(idxi)*s_S + & @@ -2591,7 +2539,7 @@ contains ! Energy flux. ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) - flux_rs${XYZ}$_vf_flat(j, k, l, E_idx) = & + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & xi_M*(vel_L(idx1)*(E_L + pres_L) + & s_M*(xi_L*(E_L + (s_S - vel_L(idx1))* & (rho_L*s_S + pres_L/ & @@ -2605,10 +2553,10 @@ contains !$acc loop seq do i = advxb, advxe - flux_rs${XYZ}$_vf_flat(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf_flat(j, k, l, i) & + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & *(vel_L(idx1) + s_M*(xi_L - 1d0)) & - + xi_P*qR_prim_rs${XYZ}$_vf_flat(j + 1, k, l, i) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & *(vel_R(idx1) + s_P*(xi_R - 1d0)) end do @@ -2616,7 +2564,7 @@ contains !$acc loop seq do i = 1, num_dims idxi = dir_idx(i) - vel_src_rs${XYZ}$_vf_flat(j, k, l, idxi) = & + vel_src_rs${XYZ}$_vf(j, k, l, idxi) = & xi_M*(vel_L(idxi) + & dir_flg(idxi)* & s_M*(xi_L - 1d0)) & @@ -2627,7 +2575,7 @@ contains !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do - flux_src_rs${XYZ}$_vf_flat(j, k, l, advxb) = vel_src_rs${XYZ}$_vf_flat(j, k, l, idx1) + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, idx1) ! Geometrical source flux for cylindrical coordinates @@ -2636,10 +2584,10 @@ contains !Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = flux_rs${XYZ}$_vf_flat(j, k, l, i) + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, contxe + idx1) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + idx1) = & xi_M*(rho_L*(vel_L(idx1)* & vel_L(idx1) + & s_M*(xi_L*(dir_flg(idx1)*s_S + & @@ -2653,7 +2601,7 @@ contains ! Geometrical source of the void fraction(s) is zero !$acc loop seq do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 end do end if #:endif @@ -2661,10 +2609,10 @@ contains if (grid_geometry == 3) then !$acc loop seq do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 end do - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, momxb + 1) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & -xi_M*(rho_L*(vel_L(idx1)* & vel_L(idx1) + & s_M*(xi_L*(dir_flg(idx1)*s_S + & @@ -2675,7 +2623,7 @@ contains s_P*(xi_R*(dir_flg(idx1)*s_S + & (1d0 - dir_flg(idx1))* & vel_R(idx1)) - vel_R(idx1)))) - flux_gsrc_rs${XYZ}$_vf_flat(j, k, l, momxe) = flux_rs${XYZ}$_vf_flat(j, k, l, momxb + 1) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif @@ -2799,48 +2747,13 @@ contains ! the Riemann problem solution integer :: i, j - allocate (gammas(1:num_fluids)) - allocate (pi_infs(1:num_fluids)) allocate (Gs(1:num_fluids)) do i = 1, num_fluids - gammas(i) = fluid_pp(i)%gamma - pi_infs(i) = fluid_pp(i)%pi_inf Gs(i) = fluid_pp(i)%G end do -!$acc update device(gammas, pi_infs, Gs) +!$acc update device( Gs) - momxb = mom_idx%beg; momxe = mom_idx%end - contxb = cont_idx%beg; contxe = cont_idx%end - bubxb = bub_idx%beg; bubxe = bub_idx%end - advxb = adv_idx%beg; advxe = adv_idx%end - intxb = internalEnergies_idx%beg; intxe = internalEnergies_idx%end - strxb = stress_idx%beg; strxe = stress_idx%end -!$acc update device(momxb, momxe, contxb, contxe, bubxb, bubxe, advxb, advxe, intxb, intxe, strxb, strxe) - - if (bubbles) then - allocate (rs(1:nb)) - allocate (vs(1:nb)) - if (.not. polytropic) then - allocate (ps(1:nb)) - allocate (ms(1:nb)) - end if - - do i = 1, nb - rs(i) = bub_idx%rs(i) - vs(i) = bub_idx%vs(i) - if (.not. polytropic) then - ps(i) = bub_idx%ps(i) - ms(i) = bub_idx%ms(i) - end if - end do - -!$acc update device(rs, vs) - if (.not. polytropic) then -!$acc update device(ps, ms) - end if - - end if if (any(Re_size > 0)) then allocate (Res(1:2, 1:maxval(Re_size))) @@ -2855,27 +2768,6 @@ contains !$acc update device(Res, Re_idx, Re_size) end if - allocate (qL_prim_rsx_vf(1:sys_size), qR_prim_rsx_vf(1:sys_size)) - allocate (qL_prim_rsy_vf(1:sys_size), qR_prim_rsy_vf(1:sys_size)) - allocate (qL_prim_rsz_vf(1:sys_size), qR_prim_rsz_vf(1:sys_size)) - - allocate (flux_gsrc_rsx_vf(1:sys_size)) - allocate (flux_gsrc_rsy_vf(1:sys_size)) - allocate (flux_gsrc_rsz_vf(1:sys_size)) - - allocate (vel_src_rsx_vf(1:num_dims)) - allocate (vel_src_rsy_vf(1:num_dims)) - allocate (vel_src_rsz_vf(1:num_dims)) - - if (any(Re_size > 0)) then - ! TODO: check this is the proper allocation for - ! Re_avg_rs_vf - allocate (Re_avg_rs_vf(1:2)) - - allocate (Re_avg_rsx_vf(1:2)) - allocate (Re_avg_rsy_vf(1:2)) - allocate (Re_avg_rsz_vf(1:2)) - end if allocate (vel_avg(1:num_dims)) @@ -2936,26 +2828,26 @@ contains is1%beg = -1; is2%beg = 0; is3%beg = 0 is1%end = m; is2%end = n; is3%end = p - !allocate(qL_prim_rsx_vf_flat(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) - !allocate(qR_prim_rsx_vf_flat(is1%beg + 1:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) - allocate (flux_rsx_vf_flat(is1%beg:is1%end, & + !allocate(qL_prim_rsx_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + !allocate(qR_prim_rsx_vf(is1%beg + 1:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + allocate (flux_rsx_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) - allocate (flux_gsrc_rsx_vf_flat(is1%beg:is1%end, & + allocate (flux_gsrc_rsx_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) - allocate (flux_src_rsx_vf_flat(is1%beg:is1%end, & + allocate (flux_src_rsx_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, advxb:sys_size)) - allocate (vel_src_rsx_vf_flat(is1%beg:is1%end, & + allocate (vel_src_rsx_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:num_dims)) if (qbmm) then - allocate (mom_sp_rsx_vf_flat(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) + allocate (mom_sp_rsx_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) end if if (any(Re_size > 0)) then - allocate (Re_avg_rsx_vf_flat(is1%beg:is1%end, & + allocate (Re_avg_rsx_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:2)) end if @@ -2965,27 +2857,27 @@ contains is1%beg = -1; is2%beg = 0; is3%beg = 0 is1%end = n; is2%end = m; is3%end = p - !allocate(qL_prim_rsy_vf_flat(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) - !allocate(qR_prim_rsy_vf_flat(is1%beg + 1:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) - allocate (flux_rsy_vf_flat(is1%beg:is1%end, & + !allocate(qL_prim_rsy_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + !allocate(qR_prim_rsy_vf(is1%beg + 1:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + allocate (flux_rsy_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) - allocate (flux_gsrc_rsy_vf_flat(is1%beg:is1%end, & + allocate (flux_gsrc_rsy_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) - allocate (flux_src_rsy_vf_flat(is1%beg:is1%end, & + allocate (flux_src_rsy_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, advxb:sys_size)) - allocate (vel_src_rsy_vf_flat(is1%beg:is1%end, & + allocate (vel_src_rsy_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:num_dims)) if (qbmm) then - allocate (mom_sp_rsy_vf_flat(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) + allocate (mom_sp_rsy_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) end if if (any(Re_size > 0)) then - allocate (Re_avg_rsy_vf_flat(is1%beg:is1%end, & + allocate (Re_avg_rsy_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:2)) end if @@ -2995,27 +2887,27 @@ contains is1%beg = -1; is2%beg = 0; is3%beg = 0 is1%end = p; is2%end = n; is3%end = m - !allocate(qL_prim_rsz_vf_flat(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) - !allocate(qR_prim_rsz_vf_flat(is1%beg + 1:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) - allocate (flux_rsz_vf_flat(is1%beg:is1%end, & + !allocate(qL_prim_rsz_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + !allocate(qR_prim_rsz_vf(is1%beg + 1:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + allocate (flux_rsz_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) - allocate (flux_gsrc_rsz_vf_flat(is1%beg:is1%end, & + allocate (flux_gsrc_rsz_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) - allocate (flux_src_rsz_vf_flat(is1%beg:is1%end, & + allocate (flux_src_rsz_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, advxb:sys_size)) - allocate (vel_src_rsz_vf_flat(is1%beg:is1%end, & + allocate (vel_src_rsz_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:num_dims)) if (qbmm) then - allocate (mom_sp_rsz_vf_flat(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) + allocate (mom_sp_rsz_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) end if if (any(Re_size > 0)) then - allocate (Re_avg_rsz_vf_flat(is1%beg:is1%end, & + allocate (Re_avg_rsz_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:2)) end if @@ -3048,17 +2940,17 @@ contains !! @param iy Index bounds in the y-dir !! @param iz Index bounds in the z-dir subroutine s_populate_riemann_states_variables_buffers( & ! ------------ - qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & - qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, dqR_prim_dx_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & dqR_prim_dy_vf, & dqR_prim_dz_vf, & qR_prim_vf, & norm_dir, ix, iy, iz) - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), & allocatable, dimension(:), & @@ -3106,8 +2998,8 @@ contains do i = 1, sys_size do l = is3%beg, is3%end do k = is2%beg, is2%end - qL_prim_rsx_vf_flat(-1, k, l, i) = & - qR_prim_rsx_vf_flat(0, k, l, i) + qL_prim_rsx_vf(-1, k, l, i) = & + qR_prim_rsx_vf(0, k, l, i) end do end do end do @@ -3161,8 +3053,8 @@ contains do i = 1, sys_size do l = is3%beg, is3%end do k = is2%beg, is2%end - qR_prim_rsx_vf_flat(m + 1, k, l, i) = & - qL_prim_rsx_vf_flat(m, k, l, i) + qR_prim_rsx_vf(m + 1, k, l, i) = & + qL_prim_rsx_vf(m, k, l, i) end do end do end do @@ -3220,8 +3112,8 @@ contains do i = 1, sys_size do l = is3%beg, is3%end do k = is2%beg, is2%end - qL_prim_rsy_vf_flat(-1, k, l, i) = & - qR_prim_rsy_vf_flat(0, k, l, i) + qL_prim_rsy_vf(-1, k, l, i) = & + qR_prim_rsy_vf(0, k, l, i) end do end do end do @@ -3270,8 +3162,8 @@ contains do i = 1, sys_size do l = is3%beg, is3%end do k = is2%beg, is2%end - qR_prim_rsy_vf_flat(n + 1, k, l, i) = & - qL_prim_rsy_vf_flat(n, k, l, i) + qR_prim_rsy_vf(n + 1, k, l, i) = & + qL_prim_rsy_vf(n, k, l, i) end do end do end do @@ -3323,8 +3215,8 @@ contains do i = 1, sys_size do l = is3%beg, is3%end do k = is2%beg, is2%end - qL_prim_rsz_vf_flat(-1, k, l, i) = & - qR_prim_rsz_vf_flat(0, k, l, i) + qL_prim_rsz_vf(-1, k, l, i) = & + qR_prim_rsz_vf(0, k, l, i) end do end do end do @@ -3367,8 +3259,8 @@ contains do i = 1, sys_size do l = is3%beg, is3%end do k = is2%beg, is2%end - qR_prim_rsz_vf_flat(p + 1, k, l, i) = & - qL_prim_rsz_vf_flat(p, k, l, i) + qR_prim_rsz_vf(p + 1, k, l, i) = & + qL_prim_rsz_vf(p, k, l, i) end do end do end do @@ -3467,7 +3359,7 @@ contains do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end + 1 - mom_sp_rsx_vf_flat(j, k, l, i) = mom_sp(i)%sf(j, k, l) + mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) end do end do end do @@ -3498,7 +3390,7 @@ contains do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end + 1 - mom_sp_rsy_vf_flat(j, k, l, i) = mom_sp(i)%sf(k, j, l) + mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) end do end do end do @@ -3529,7 +3421,7 @@ contains do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end + 1 - mom_sp_rsz_vf_flat(j, k, l, i) = mom_sp(i)%sf(l, k, j) + mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) end do end do end do @@ -3611,7 +3503,7 @@ contains + dvelR_dx_vf(1)%sf(j + 1, k, l)) tau_Re(1, 1) = (4d0/3d0)*dvel_avg_dx(1)/ & - Re_avg_rsx_vf_flat(j, k, l, 1) + Re_avg_rsx_vf(j, k, l, 1) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & @@ -3619,7 +3511,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, 1)* & + vel_src_rsx_vf(j, k, l, 1)* & tau_Re(1, 1) end do @@ -3637,7 +3529,7 @@ contains + dvelR_dx_vf(1)%sf(j + 1, k, l)) tau_Re(1, 1) = dvel_avg_dx(1)/ & - Re_avg_rsx_vf_flat(j, k, l, 2) + Re_avg_rsx_vf(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & @@ -3645,7 +3537,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, 1)* & + vel_src_rsx_vf(j, k, l, 1)* & tau_Re(1, 1) end do @@ -3676,10 +3568,10 @@ contains tau_Re(1, 1) = -(2d0/3d0)*(dvel_avg_dy(2) + & avg_vel(2)/y_cc(k))/ & - Re_avg_rsx_vf_flat(j, k, l, 1) + Re_avg_rsx_vf(j, k, l, 1) tau_Re(1, 2) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & - Re_avg_rsx_vf_flat(j, k, l, 1) + Re_avg_rsx_vf(j, k, l, 1) !$acc loop seq do i = 1, 2 @@ -3690,7 +3582,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, i)* & + vel_src_rsx_vf(j, k, l, i)* & tau_Re(1, i) end do @@ -3714,7 +3606,7 @@ contains tau_Re(1, 1) = (dvel_avg_dy(2) + & avg_vel(2)/y_cc(k))/ & - Re_avg_rsx_vf_flat(j, k, l, 2) + Re_avg_rsx_vf(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & @@ -3722,7 +3614,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, 1)* & + vel_src_rsx_vf(j, k, l, 1)* & tau_Re(1, 1) end do @@ -3749,10 +3641,10 @@ contains + dvelR_dx_vf(3)%sf(j + 1, k, l)) tau_Re(1, 1) = -(2d0/3d0)*dvel_avg_dz(3)/y_cc(k)/ & - Re_avg_rsx_vf_flat(j, k, l, 1) + Re_avg_rsx_vf(j, k, l, 1) tau_Re(1, 3) = (dvel_avg_dz(1)/y_cc(k) + dvel_avg_dx(3))/ & - Re_avg_rsx_vf_flat(j, k, l, 1) + Re_avg_rsx_vf(j, k, l, 1) !$acc loop seq do i = 1, 3, 2 @@ -3763,7 +3655,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, i)* & + vel_src_rsx_vf(j, k, l, i)* & tau_Re(1, i) end do @@ -3783,7 +3675,7 @@ contains + dvelR_dz_vf(3)%sf(j + 1, k, l)) tau_Re(1, 1) = dvel_avg_dz(3)/y_cc(k)/ & - Re_avg_rsx_vf_flat(j, k, l, 2) + Re_avg_rsx_vf(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & @@ -3791,7 +3683,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, 1)* & + vel_src_rsx_vf(j, k, l, 1)* & tau_Re(1, 1) end do @@ -3826,12 +3718,12 @@ contains end do tau_Re(2, 1) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & - Re_avg_rsy_vf_flat(k, j, l, 1) + Re_avg_rsy_vf(k, j, l, 1) tau_Re(2, 2) = (4d0*dvel_avg_dy(2) & - 2d0*dvel_avg_dx(1) & - 2d0*avg_vel(2)/y_cb(k))/ & - (3d0*Re_avg_rsy_vf_flat(k, j, l, 1)) + (3d0*Re_avg_rsy_vf(k, j, l, 1)) !$acc loop seq do i = 1, 2 @@ -3842,7 +3734,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsy_vf_flat(k, j, l, i)* & + vel_src_rsy_vf(k, j, l, i)* & tau_Re(2, i) end do @@ -3869,7 +3761,7 @@ contains tau_Re(2, 2) = (dvel_avg_dx(1) + dvel_avg_dy(2) + & avg_vel(2)/y_cb(k))/ & - Re_avg_rsy_vf_flat(k, j, l, 2) + Re_avg_rsy_vf(k, j, l, 2) flux_src_vf(momxb + 1)%sf(j, k, l) = & flux_src_vf(momxb + 1)%sf(j, k, l) - & @@ -3877,7 +3769,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsy_vf_flat(k, j, l, 2)* & + vel_src_rsy_vf(k, j, l, 2)* & tau_Re(2, 2) end do @@ -3907,11 +3799,11 @@ contains + dvelR_dy_vf(3)%sf(j, k + 1, l)) tau_Re(2, 2) = -(2d0/3d0)*dvel_avg_dz(3)/y_cb(k)/ & - Re_avg_rsy_vf_flat(k, j, l, 1) + Re_avg_rsy_vf(k, j, l, 1) tau_Re(2, 3) = ((dvel_avg_dz(2) - avg_vel(3))/ & y_cb(k) + dvel_avg_dy(3))/ & - Re_avg_rsy_vf_flat(k, j, l, 1) + Re_avg_rsy_vf(k, j, l, 1) !$acc loop seq do i = 2, 3 @@ -3922,7 +3814,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsy_vf_flat(k, j, l, i)* & + vel_src_rsy_vf(k, j, l, i)* & tau_Re(2, i) end do @@ -3942,7 +3834,7 @@ contains + dvelR_dz_vf(3)%sf(j, k + 1, l)) tau_Re(2, 2) = dvel_avg_dz(3)/y_cb(k)/ & - Re_avg_rsy_vf_flat(k, j, l, 2) + Re_avg_rsy_vf(k, j, l, 2) flux_src_vf(momxb + 1)%sf(j, k, l) = & flux_src_vf(momxb + 1)%sf(j, k, l) - & @@ -3950,7 +3842,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsy_vf_flat(k, j, l, 2)* & + vel_src_rsy_vf(k, j, l, 2)* & tau_Re(2, 2) end do @@ -3995,19 +3887,19 @@ contains end do tau_Re(3, 1) = (dvel_avg_dz(1)/y_cc(k) + dvel_avg_dx(3))/ & - Re_avg_rsz_vf_flat(l, k, j, 1)/ & + Re_avg_rsz_vf(l, k, j, 1)/ & y_cc(k) tau_Re(3, 2) = ((dvel_avg_dz(2) - avg_vel(3))/ & y_cc(k) + dvel_avg_dy(3))/ & - Re_avg_rsz_vf_flat(l, k, j, 1)/ & + Re_avg_rsz_vf(l, k, j, 1)/ & y_cc(k) tau_Re(3, 3) = (4d0*dvel_avg_dz(3)/y_cc(k) & - 2d0*dvel_avg_dx(1) & - 2d0*dvel_avg_dy(2) & + 4d0*avg_vel(2)/y_cc(k))/ & - (3d0*Re_avg_rsz_vf_flat(l, k, j, 1))/ & + (3d0*Re_avg_rsz_vf(l, k, j, 1))/ & y_cc(k) !$acc loop seq @@ -4019,7 +3911,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsz_vf_flat(l, k, j, i)* & + vel_src_rsz_vf(l, k, j, i)* & tau_Re(3, i) end do @@ -4051,7 +3943,7 @@ contains + dvel_avg_dy(2) & + dvel_avg_dz(3)/y_cc(k) & + avg_vel(2)/y_cc(k))/ & - Re_avg_rsz_vf_flat(l, k, j, 2)/ & + Re_avg_rsz_vf(l, k, j, 2)/ & y_cc(k) flux_src_vf(momxe)%sf(j, k, l) = & @@ -4060,7 +3952,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsz_vf_flat(l, k, j, 3)* & + vel_src_rsz_vf(l, k, j, 3)* & tau_Re(3, 3) end do @@ -4140,7 +4032,7 @@ contains + dvelR_dx_vf(1)%sf(j + 1, k, l)) tau_Re(1, 1) = (4d0/3d0)*dvel_avg_dx(1)/ & - Re_avg_rsx_vf_flat(j, k, l, 1) + Re_avg_rsx_vf(j, k, l, 1) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & @@ -4148,7 +4040,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, 1)* & + vel_src_rsx_vf(j, k, l, 1)* & tau_Re(1, 1) end do @@ -4166,7 +4058,7 @@ contains + dvelR_dx_vf(1)%sf(j + 1, k, l)) tau_Re(1, 1) = dvel_avg_dx(1)/ & - Re_avg_rsx_vf_flat(j, k, l, 2) + Re_avg_rsx_vf(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & @@ -4174,7 +4066,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, 1)* & + vel_src_rsx_vf(j, k, l, 1)* & tau_Re(1, 1) end do @@ -4201,10 +4093,10 @@ contains + dvelR_dx_vf(2)%sf(j + 1, k, l)) tau_Re(1, 1) = -(2d0/3d0)*dvel_avg_dy(2)/ & - Re_avg_rsx_vf_flat(j, k, l, 1) + Re_avg_rsx_vf(j, k, l, 1) tau_Re(1, 2) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & - Re_avg_rsx_vf_flat(j, k, l, 1) + Re_avg_rsx_vf(j, k, l, 1) !$acc loop seq do i = 1, 2 @@ -4215,7 +4107,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, i)* & + vel_src_rsx_vf(j, k, l, i)* & tau_Re(1, i) end do @@ -4235,7 +4127,7 @@ contains + dvelR_dy_vf(2)%sf(j + 1, k, l)) tau_Re(1, 1) = dvel_avg_dy(2)/ & - Re_avg_rsx_vf_flat(j, k, l, 2) + Re_avg_rsx_vf(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & @@ -4243,7 +4135,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, 1)* & + vel_src_rsx_vf(j, k, l, 1)* & tau_Re(1, 1) end do @@ -4270,10 +4162,10 @@ contains + dvelR_dx_vf(3)%sf(j + 1, k, l)) tau_Re(1, 1) = -(2d0/3d0)*dvel_avg_dz(3)/ & - Re_avg_rsx_vf_flat(j, k, l, 1) + Re_avg_rsx_vf(j, k, l, 1) tau_Re(1, 3) = (dvel_avg_dz(1) + dvel_avg_dx(3))/ & - Re_avg_rsx_vf_flat(j, k, l, 1) + Re_avg_rsx_vf(j, k, l, 1) !$acc loop seq do i = 1, 3, 2 @@ -4283,7 +4175,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, i)* & + vel_src_rsx_vf(j, k, l, i)* & tau_Re(1, i) end do @@ -4303,7 +4195,7 @@ contains + dvelR_dz_vf(3)%sf(j + 1, k, l)) tau_Re(1, 1) = dvel_avg_dz(3)/ & - Re_avg_rsx_vf_flat(j, k, l, 2) + Re_avg_rsx_vf(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & @@ -4311,7 +4203,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsx_vf_flat(j, k, l, 1)* & + vel_src_rsx_vf(j, k, l, 1)* & tau_Re(1, 1) end do @@ -4343,11 +4235,11 @@ contains end do tau_Re(2, 1) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & - Re_avg_rsy_vf_flat(k, j, l, 1) + Re_avg_rsy_vf(k, j, l, 1) tau_Re(2, 2) = (4d0*dvel_avg_dy(2) & - 2d0*dvel_avg_dx(1))/ & - (3d0*Re_avg_rsy_vf_flat(k, j, l, 1)) + (3d0*Re_avg_rsy_vf(k, j, l, 1)) !$acc loop seq do i = 1, 2 @@ -4358,7 +4250,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsy_vf_flat(k, j, l, i)* & + vel_src_rsy_vf(k, j, l, i)* & tau_Re(2, i) end do @@ -4381,7 +4273,7 @@ contains + dvelR_dy_vf(2)%sf(j, k + 1, l)) tau_Re(2, 2) = (dvel_avg_dx(1) + dvel_avg_dy(2))/ & - Re_avg_rsy_vf_flat(k, j, l, 2) + Re_avg_rsy_vf(k, j, l, 2) flux_src_vf(momxb + 1)%sf(j, k, l) = & flux_src_vf(momxb + 1)%sf(j, k, l) - & @@ -4389,7 +4281,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsy_vf_flat(k, j, l, 2)* & + vel_src_rsy_vf(k, j, l, 2)* & tau_Re(2, 2) end do @@ -4416,10 +4308,10 @@ contains + dvelR_dy_vf(3)%sf(j, k + 1, l)) tau_Re(2, 2) = -(2d0/3d0)*dvel_avg_dz(3)/ & - Re_avg_rsy_vf_flat(k, j, l, 1) + Re_avg_rsy_vf(k, j, l, 1) tau_Re(2, 3) = (dvel_avg_dz(2) + dvel_avg_dy(3))/ & - Re_avg_rsy_vf_flat(k, j, l, 1) + Re_avg_rsy_vf(k, j, l, 1) !$acc loop seq do i = 2, 3 @@ -4430,7 +4322,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsy_vf_flat(k, j, l, i)* & + vel_src_rsy_vf(k, j, l, i)* & tau_Re(2, i) end do @@ -4450,7 +4342,7 @@ contains + dvelR_dz_vf(3)%sf(j, k + 1, l)) tau_Re(2, 2) = dvel_avg_dz(3)/ & - Re_avg_rsy_vf_flat(k, j, l, 2) + Re_avg_rsy_vf(k, j, l, 2) flux_src_vf(momxb + 1)%sf(j, k, l) = & flux_src_vf(momxb + 1)%sf(j, k, l) - & @@ -4458,7 +4350,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsy_vf_flat(k, j, l, 2)* & + vel_src_rsy_vf(k, j, l, 2)* & tau_Re(2, 2) end do @@ -4498,15 +4390,15 @@ contains end do tau_Re(3, 1) = (dvel_avg_dz(1) + dvel_avg_dx(3))/ & - Re_avg_rsz_vf_flat(l, k, j, 1) + Re_avg_rsz_vf(l, k, j, 1) tau_Re(3, 2) = (dvel_avg_dz(2) + dvel_avg_dy(3))/ & - Re_avg_rsz_vf_flat(l, k, j, 1) + Re_avg_rsz_vf(l, k, j, 1) tau_Re(3, 3) = (4d0*dvel_avg_dz(3) & - 2d0*dvel_avg_dx(1) & - 2d0*dvel_avg_dy(2))/ & - (3d0*Re_avg_rsz_vf_flat(l, k, j, 1)) + (3d0*Re_avg_rsz_vf(l, k, j, 1)) !$acc loop seq do i = 1, 3 @@ -4517,7 +4409,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsz_vf_flat(l, k, j, i)* & + vel_src_rsz_vf(l, k, j, i)* & tau_Re(3, i) end do @@ -4545,7 +4437,7 @@ contains tau_Re(3, 3) = (dvel_avg_dx(1) & + dvel_avg_dy(2) & + dvel_avg_dz(3))/ & - Re_avg_rsz_vf_flat(l, k, j, 2) + Re_avg_rsz_vf(l, k, j, 2) flux_src_vf(momxe)%sf(j, k, l) = & flux_src_vf(momxe)%sf(j, k, l) - & @@ -4553,7 +4445,7 @@ contains flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & - vel_src_rsz_vf_flat(l, k, j, 3)* & + vel_src_rsz_vf(l, k, j, 3)* & tau_Re(3, 3) end do @@ -4597,7 +4489,7 @@ contains do j = is1%beg, is1%end do k = is2%beg, is2%end flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf_flat(j, k, l, i) + flux_rsy_vf(j, k, l, i) end do end do end do @@ -4610,7 +4502,7 @@ contains do j = is1%beg, is1%end do k = is2%beg, is2%end flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf_flat(j, k, l, i) + flux_gsrc_rsy_vf(j, k, l, i) end do end do end do @@ -4622,7 +4514,7 @@ contains do j = is1%beg, is1%end do k = is2%beg, is2%end flux_src_vf(advxb)%sf(k, j, l) = & - flux_src_rsy_vf_flat(j, k, l, advxb) + flux_src_rsy_vf(j, k, l, advxb) end do end do end do @@ -4634,7 +4526,7 @@ contains do j = is1%beg, is1%end do k = is2%beg, is2%end flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf_flat(j, k, l, i) + flux_src_rsy_vf(j, k, l, i) end do end do end do @@ -4651,7 +4543,7 @@ contains do l = is3%beg, is3%end flux_vf(i)%sf(l, k, j) = & - flux_rsz_vf_flat(j, k, l, i) + flux_rsz_vf(j, k, l, i) end do end do end do @@ -4664,7 +4556,7 @@ contains do l = is3%beg, is3%end flux_gsrc_vf(i)%sf(l, k, j) = & - flux_gsrc_rsz_vf_flat(j, k, l, i) + flux_gsrc_rsz_vf(j, k, l, i) end do end do end do @@ -4676,7 +4568,7 @@ contains do k = is2%beg, is2%end do l = is3%beg, is3%end flux_src_vf(advxb)%sf(l, k, j) = & - flux_src_rsz_vf_flat(j, k, l, advxb) + flux_src_rsz_vf(j, k, l, advxb) end do end do end do @@ -4688,7 +4580,7 @@ contains do k = is2%beg, is2%end do l = is3%beg, is3%end flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf_flat(j, k, l, i) + flux_src_rsz_vf(j, k, l, i) end do end do end do @@ -4702,7 +4594,7 @@ contains do k = is2%beg, is2%end do j = is1%beg, is1%end flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf_flat(j, k, l, i) + flux_rsx_vf(j, k, l, i) end do end do end do @@ -4713,7 +4605,7 @@ contains do k = is2%beg, is2%end do j = is1%beg, is1%end flux_src_vf(advxb)%sf(j, k, l) = & - flux_src_rsx_vf_flat(j, k, l, advxb) + flux_src_rsx_vf(j, k, l, advxb) end do end do end do @@ -4725,7 +4617,7 @@ contains do k = is2%beg, is2%end do j = is1%beg, is1%end flux_src_vf(i)%sf(j, k, l) = & - flux_src_rsx_vf_flat(j, k, l, i) + flux_src_rsx_vf(j, k, l, i) end do end do end do @@ -4786,47 +4678,47 @@ contains s_convert_to_mixture_variables => null() if (Re_size(1) > 0) then - deallocate (Re_avg_rsx_vf_flat) + deallocate (Re_avg_rsx_vf) end if - deallocate (vel_src_rsx_vf_flat) - deallocate (flux_rsx_vf_flat) - deallocate (flux_src_rsx_vf_flat) - deallocate (flux_gsrc_rsx_vf_flat) + deallocate (vel_src_rsx_vf) + deallocate (flux_rsx_vf) + deallocate (flux_src_rsx_vf) + deallocate (flux_gsrc_rsx_vf) if (qbmm) then - deallocate (mom_sp_rsx_vf_flat) + deallocate (mom_sp_rsx_vf) end if - !deallocate(qL_prim_rsx_vf_flat) - !deallocate(qR_prim_rsx_vf_flat) + !deallocate(qL_prim_rsx_vf) + !deallocate(qR_prim_rsx_vf) if (n == 0) return if (Re_size(1) > 0) then - deallocate (Re_avg_rsy_vf_flat) + deallocate (Re_avg_rsy_vf) end if - deallocate (vel_src_rsy_vf_flat) - deallocate (flux_rsy_vf_flat) - deallocate (flux_src_rsy_vf_flat) - deallocate (flux_gsrc_rsy_vf_flat) + deallocate (vel_src_rsy_vf) + deallocate (flux_rsy_vf) + deallocate (flux_src_rsy_vf) + deallocate (flux_gsrc_rsy_vf) if (qbmm) then - deallocate (mom_sp_rsy_vf_flat) + deallocate (mom_sp_rsy_vf) end if - !deallocate(qL_prim_rsy_vf_flat) - !deallocate(qR_prim_rsy_vf_flat) + !deallocate(qL_prim_rsy_vf) + !deallocate(qR_prim_rsy_vf) if (p == 0) return if (Re_size(1) > 0) then - deallocate (Re_avg_rsz_vf_flat) + deallocate (Re_avg_rsz_vf) end if - deallocate (vel_src_rsz_vf_flat) - deallocate (flux_rsz_vf_flat) - deallocate (flux_src_rsz_vf_flat) - deallocate (flux_gsrc_rsz_vf_flat) + deallocate (vel_src_rsz_vf) + deallocate (flux_rsz_vf) + deallocate (flux_src_rsz_vf) + deallocate (flux_gsrc_rsz_vf) if (qbmm) then - deallocate (mom_sp_rsz_vf_flat) + deallocate (mom_sp_rsz_vf) end if - !deallocate(qL_prim_rsz_vf_flat) - !deallocate(qR_prim_rsz_vf_flat) + !deallocate(qL_prim_rsz_vf) + !deallocate(qR_prim_rsz_vf) end subroutine s_finalize_riemann_solvers_module ! --------------------- diff --git a/src/simulation/m_time_steppers.f90 b/src/simulation/m_time_steppers.f90 index 0e2b61cd7c..d4dd514dc5 100644 --- a/src/simulation/m_time_steppers.f90 +++ b/src/simulation/m_time_steppers.f90 @@ -124,7 +124,7 @@ subroutine s_initialize_time_steppers_module() ! ----------------------- ! Allocating the cell-average primitive variables allocate (q_prim_vf(1:sys_size)) - + do i = 1, adv_idx%end allocate (q_prim_vf(i)%sf(ix%beg:ix%end, & iy%beg:iy%end, & diff --git a/src/simulation/m_variables_conversion.f90 b/src/simulation/m_variables_conversion.f90 index 0f32a9000c..3cef9d119d 100644 --- a/src/simulation/m_variables_conversion.f90 +++ b/src/simulation/m_variables_conversion.f90 @@ -103,16 +103,11 @@ end subroutine s_compute_abstract_average_state !> @} integer :: ixb, ixe, iyb, iye, izb, ize - integer :: momxb, momxe - integer :: contxb, contxe - integer :: bubxb, bubxe - integer :: advxb, advxe - integer :: strxb, strxe - real(kind(0d0)), allocatable, dimension(:) :: gammas, pi_infs, Gs + real(kind(0d0)), allocatable, dimension(:) :: Gs integer, allocatable, dimension(:) :: bubrs real(kind(0d0)), allocatable, dimension(:, :) :: Res -!$acc declare create(ixb, ixe, iyb, iye, izb, ize, momxb, momxe, bubxb, bubxe, contxb, contxe, advxb, advxe, strxb, strxe, gammas, pi_infs, bubrs, Gs, Res) +!$acc declare create(ixb, ixe, iyb, iye, izb, ize, bubrs, Gs, Res) integer :: is1b, is2b, is3b, is1e, is2e, is3e !$acc declare create(is1b, is2b, is3b, is1e, is2e, is3e) @@ -149,7 +144,6 @@ end subroutine s_compute_abstract_average_state subroutine s_convert_mixture_to_mixture_variables(qK_vf, rho_K, & gamma_K, pi_inf_K, & Re_K, i, j, k, G_K, G) -!$acc routine seq type(scalar_field), dimension(sys_size), intent(IN) :: qK_vf @@ -187,7 +181,6 @@ end subroutine s_convert_mixture_to_mixture_variables ! ---------------- subroutine s_convert_species_to_mixture_variables_bubbles(qK_vf, rho_K, & gamma_K, pi_inf_K, & Re_K, i, j, k, G_K, G) -!!$acc routine seq type(scalar_field), dimension(sys_size), intent(IN) :: qK_vf @@ -270,7 +263,6 @@ end subroutine s_convert_species_to_mixture_variables_bubbles ! ---------------- subroutine s_convert_species_to_mixture_variables(qK_vf, rho_K, & gamma_K, pi_inf_K, & Re_K, k, l, r, G_K, G) -!!$acc routine seq type(scalar_field), dimension(sys_size), intent(IN) :: qK_vf @@ -461,13 +453,6 @@ subroutine s_initialize_variables_conversion_module() ! ---------------- integer :: i, j - momxb = mom_idx%beg; momxe = mom_idx%end - bubxb = bub_idx%beg; bubxe = bub_idx%end - advxb = adv_idx%beg; advxe = adv_idx%end - contxb = cont_idx%beg; contxe = cont_idx%end - strxb = stress_idx%beg; strxe = stress_idx%end -!$acc update device(momxb, momxe, bubxb, bubxe, advxb, advxe, contxb, contxe, strxb, strxe) - ixb = -buff_size ixe = m - ixb @@ -484,8 +469,6 @@ subroutine s_initialize_variables_conversion_module() ! ---------------- !$acc update device(ixb, ixe, iyb, iye, izb, ize) - allocate (gammas(1:num_fluids)) - allocate (pi_infs(1:num_fluids)) allocate (Gs(1:num_fluids)) if (any(Re_size > 0)) then @@ -495,11 +478,9 @@ subroutine s_initialize_variables_conversion_module() ! ---------------- allocate (bubrs(1:nb)) do i = 1, num_fluids - gammas(i) = fluid_pp(i)%gamma - pi_infs(i) = fluid_pp(i)%pi_inf Gs(i) = fluid_pp(i)%G end do -!$acc update device(gammas, pi_infs, Gs) +!$acc update device(Gs) !TODO: this update was in previous version: (no longer needed?) !!!$acc update device(small_alf, dflt_real, dflt_int, pi, nnode, sgm_eps) @@ -593,6 +574,7 @@ subroutine s_convert_conservative_to_primitive_variables(qK_cons_vf, & integer :: i, j, k, l !< Generic loop iterators + if ((model_eqns /= 4) .and. (bubbles .neqv. .true.)) then !$acc parallel loop collapse(3) gang vector default(present) private( alpha_K, alpha_rho_K, Re_K) do l = izb, ize @@ -649,6 +631,7 @@ subroutine s_convert_conservative_to_primitive_variables(qK_cons_vf, & end do end do !$acc end parallel loop + elseif ((model_eqns /= 4)) then !TODO: add routine below for bubble + hypo !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_K, alpha_K, nRtmp) do l = izb, ize @@ -897,7 +880,7 @@ end subroutine s_convert_primitive_to_flux_variables ! ----------------- subroutine s_finalize_variables_conversion_module() ! ------------------ - deallocate (gammas, pi_infs, Gs) + deallocate ( Gs) deallocate (bubrs) s_convert_to_mixture_variables => null() diff --git a/src/simulation/m_viscous.f90 b/src/simulation/m_viscous.f90 new file mode 100644 index 0000000000..c357f9c0cb --- /dev/null +++ b/src/simulation/m_viscous.f90 @@ -0,0 +1,1366 @@ +!> +!! @file m_viscous.f90 +!! @brief Contains module m_viscous + +!> @brief The module contains the subroutines used to + + +module m_viscous + + ! Dependencies ============================================================= + use m_derived_types !< Definitions of the derived types + + use m_global_parameters !< Definitions of the global parameters + + use m_weno + ! ========================================================================== + + private; public s_get_viscous, & + s_compute_viscous_stress_tensor, & + s_initialize_viscous_module, & + s_finalize_viscous_module + + type(int_bounds_info) :: iv + type(int_bounds_info) :: is1, is2, is3 + !$acc declare create(is1, is2, is3, iv) + + real(kind(0d0)), allocatable, dimension(:, :) :: Res +!$acc declare create(Res) + + + contains + + subroutine s_initialize_viscous_module() + integer :: i, j !< generic loop iterators + + + + allocate (Res(1:2, 1:maxval(Re_size))) + + do i = 1, 2 + do j = 1, Re_size(i) + Res(i, j) = fluid_pp(Re_idx(i, j))%Re(i) + end do + end do +!$acc update device(Res, Re_idx, Re_size) + + + end subroutine s_initialize_viscous_module + + !> The purpose of this subroutine is to compute the viscous + ! stress tensor for the cells directly next to the axis in + ! cylindrical coordinates. This is necessary to avoid the + ! 1/r singularity that arises at the cell boundary coinciding + ! with the axis, i.e., y_cb(-1) = 0. + ! @param q_prim_vf Cell-average primitive variables + ! @param grad_x_vf Cell-average primitive variable derivatives, x-dir + ! @param grad_y_vf Cell-average primitive variable derivatives, y-dir + ! @param grad_z_vf Cell-average primitive variable derivatives, z-dir + subroutine s_compute_viscous_stress_tensor(q_prim_vf, grad_x_vf, grad_y_vf, grad_z_vf, & + tau_Re_vf, & + ix, iy, iz) ! --- + + type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf + type(scalar_field), dimension(num_dims), intent(IN) :: grad_x_vf, grad_y_vf, grad_z_vf + + type(scalar_field), dimension(1:sys_size) :: tau_Re_vf + + real(kind(0d0)) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables + real(kind(0d0)), dimension(2) :: Re_visc + real(kind(0d0)), dimension(num_fluids) :: alpha_visc, alpha_rho_visc + + real(kind(0d0)), dimension(num_dims, num_dims) :: tau_Re + + integer :: i, j, k, l, q !< Generic loop iterator + + type(int_bounds_info) :: ix, iy, iz + + !$acc update device(ix, iy, iz) + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg, ix%end + !$acc loop seq + do i = momxb, E_idx + tau_Re_vf(i)%sf(j, k, l) = 0d0 + end do + end do + end do + end do + if (Re_size(1) > 0) then ! Shear stresses + !$acc parallel loop collapse(3) gang vector default(present) private(alpha_visc, alpha_rho_visc, Re_visc, tau_Re ) + do l = iz%beg, iz%end + do k = -1, 1 + do j = ix%beg, ix%end + + !$acc loop seq + do i = 1, num_fluids + alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) + alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) + end do + + if (bubbles) then + rho_visc = 0d0 + gamma_visc = 0d0 + pi_inf_visc = 0d0 + + if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + else if ((model_eqns == 2) .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids - 1 + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + else + rho_visc = alpha_rho_visc(1) + gamma_visc = gammas(1) + pi_inf_visc = pi_infs(1) + end if + else + rho_visc = 0d0 + gamma_visc = 0d0 + pi_inf_visc = 0d0 + + alpha_visc_sum = 0d0 + + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) + alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) + alpha_visc_sum = alpha_visc_sum + alpha_visc(i) + end do + + alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) + + end if + + !$acc loop seq + do i = 1, num_fluids + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + + if (any(Re_size > 0)) then + !$acc loop seq + do i = 1, 2 + Re_visc(i) = dflt_real + + if (Re_size(i) > 0) Re_visc(i) = 0d0 + !$acc loop seq + do q = 1, Re_size(i) + Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & + + Re_visc(i) + end do + + Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) + + end do + end if + end if + + tau_Re(2, 1) = (grad_y_vf(1)%sf(j, k, l) + & + grad_x_vf(2)%sf(j, k, l))/ & + Re_visc(1) + + tau_Re(2, 2) = (4d0*grad_y_vf(2)%sf(j, k, l) & + - 2d0*grad_x_vf(1)%sf(j, k, l) & + - 2d0*q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/ & + (3d0*Re_visc(1)) + !$acc loop seq + do i = 1, 2 + tau_Re_vf(contxe + i)%sf(j, k, l) = & + tau_Re_vf(contxe + i)%sf(j, k, l) - & + tau_Re(2, i) + + tau_Re_vf(E_idx)%sf(j, k, l) = & + tau_Re_vf(E_idx)%sf(j, k, l) - & + q_prim_vf(contxe + i)%sf(j, k, l)*tau_Re(2, i) + end do + end do + end do + end do + end if + + if (Re_size(2) > 0) then ! Bulk stresses + !$acc parallel loop collapse(3) gang vector default(present) private(alpha_visc, alpha_rho_visc, Re_visc, tau_Re ) + do l = iz%beg, iz%end + do k = -1, 1 + do j = ix%beg, ix%end + + !$acc loop seq + do i = 1, num_fluids + alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) + alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) + end do + + if (bubbles) then + rho_visc = 0d0 + gamma_visc = 0d0 + pi_inf_visc = 0d0 + + if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + else if ((model_eqns == 2) .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids - 1 + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + else + rho_visc = alpha_rho_visc(1) + gamma_visc = gammas(1) + pi_inf_visc = pi_infs(1) + end if + else + rho_visc = 0d0 + gamma_visc = 0d0 + pi_inf_visc = 0d0 + + alpha_visc_sum = 0d0 + + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) + alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) + alpha_visc_sum = alpha_visc_sum + alpha_visc(i) + end do + + alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) + + end if + + !$acc loop seq + do i = 1, num_fluids + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + + if (any(Re_size > 0)) then + !$acc loop seq + do i = 1, 2 + Re_visc(i) = dflt_real + + if (Re_size(i) > 0) Re_visc(i) = 0d0 + !$acc loop seq + do q = 1, Re_size(i) + Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & + + Re_visc(i) + end do + + Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) + + end do + end if + end if + + tau_Re(2, 2) = (grad_x_vf(1)%sf(j, k, l) + & + grad_y_vf(2)%sf(j, k, l) + & + q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/ & + Re_visc(2) + + tau_Re_vf(momxb + 1)%sf(j, k, l) = & + tau_Re_vf(momxb + 1)%sf(j, k, l) - & + tau_Re(2, 2) + + tau_Re_vf(E_idx)%sf(j, k, l) = & + tau_Re_vf(E_idx)%sf(j, k, l) - & + q_prim_vf(momxb + 1)%sf(j, k, l)*tau_Re(2, 2) + + end do + end do + end do + end if + + if (p == 0) return + + if (Re_size(1) > 0) then ! Shear stresses + !$acc parallel loop collapse(3) gang vector default(present) private(alpha_visc, alpha_rho_visc, Re_visc, tau_Re ) + do l = iz%beg, iz%end + do k = -1, 1 + do j = ix%beg, ix%end + + !$acc loop seq + do i = 1, num_fluids + alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) + alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) + end do + + if (bubbles) then + rho_visc = 0d0 + gamma_visc = 0d0 + pi_inf_visc = 0d0 + + if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + else if ((model_eqns == 2) .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids - 1 + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + else + rho_visc = alpha_rho_visc(1) + gamma_visc = gammas(1) + pi_inf_visc = pi_infs(1) + end if + else + rho_visc = 0d0 + gamma_visc = 0d0 + pi_inf_visc = 0d0 + + alpha_visc_sum = 0d0 + + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) + alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) + alpha_visc_sum = alpha_visc_sum + alpha_visc(i) + end do + + alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) + + end if + + !$acc loop seq + do i = 1, num_fluids + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + + if (any(Re_size > 0)) then + !$acc loop seq + do i = 1, 2 + Re_visc(i) = dflt_real + + if (Re_size(i) > 0) Re_visc(i) = 0d0 + !$acc loop seq + do q = 1, Re_size(i) + Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & + + Re_visc(i) + end do + + Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) + + end do + end if + end if + + tau_Re(2, 2) = -(2d0/3d0)*grad_z_vf(3)%sf(j, k, l)/y_cc(k)/ & + Re_visc(1) + + tau_Re(2, 3) = ((grad_z_vf(2)%sf(j, k, l) - & + q_prim_vf(momxe)%sf(j, k, l))/ & + y_cc(k) + grad_y_vf(3)%sf(j, k, l))/ & + Re_visc(1) + + !$acc loop seq + do i = 2, 3 + tau_Re_vf(contxe + i)%sf(j, k, l) = & + tau_Re_vf(contxe + i)%sf(j, k, l) - & + tau_Re(2, i) + + tau_Re_vf(E_idx)%sf(j, k, l) = & + tau_Re_vf(E_idx)%sf(j, k, l) - & + q_prim_vf(contxe + i)%sf(j, k, l)*tau_Re(2, i) + end do + + end do + end do + end do + end if + + if (Re_size(2) > 0) then ! Bulk stresses + !$acc parallel loop collapse(3) gang vector default(present) private(alpha_visc, alpha_rho_visc, Re_visc, tau_Re ) + do l = iz%beg, iz%end + do k = -1, 1 + do j = ix%beg, ix%end + + !$acc loop seq + do i = 1, num_fluids + alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) + alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) + end do + + if (bubbles) then + rho_visc = 0d0 + gamma_visc = 0d0 + pi_inf_visc = 0d0 + + if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + else if ((model_eqns == 2) .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids - 1 + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + else + rho_visc = alpha_rho_visc(1) + gamma_visc = gammas(1) + pi_inf_visc = pi_infs(1) + end if + else + rho_visc = 0d0 + gamma_visc = 0d0 + pi_inf_visc = 0d0 + + alpha_visc_sum = 0d0 + + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) + alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) + alpha_visc_sum = alpha_visc_sum + alpha_visc(i) + end do + + alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) + + end if + + !$acc loop seq + do i = 1, num_fluids + rho_visc = rho_visc + alpha_rho_visc(i) + gamma_visc = gamma_visc + alpha_visc(i)*gammas(i) + pi_inf_visc = pi_inf_visc + alpha_visc(i)*pi_infs(i) + end do + + if (any(Re_size > 0)) then + !$acc loop seq + do i = 1, 2 + Re_visc(i) = dflt_real + + if (Re_size(i) > 0) Re_visc(i) = 0d0 + !$acc loop seq + do q = 1, Re_size(i) + Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & + + Re_visc(i) + end do + + Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) + + end do + end if + end if + + tau_Re(2, 2) = grad_z_vf(3)%sf(j, k, l)/y_cc(k)/ & + Re_visc(2) + + tau_Re_vf(momxb + 1)%sf(j, k, l) = & + tau_Re_vf(momxb + 1)%sf(j, k, l) - & + tau_Re(2, 2) + + tau_Re_vf(E_idx)%sf(j, k, l) = & + tau_Re_vf(E_idx)%sf(j, k, l) - & + q_prim_vf(momxb + 1)%sf(j, k, l)*tau_Re(2, 2) + + end do + end do + end do + end if + end subroutine s_compute_viscous_stress_tensor ! ---------------------------------------- + + !> Computes the scalar gradient fields via finite differences + !! @param var Variable to compute derivative of + !! @param grad_x First coordinate direction component of the derivative + !! @param grad_y Second coordinate direction component of the derivative + !! @param grad_z Third coordinate direction component of the derivative + !! @param norm Norm of the gradient vector + subroutine s_compute_fd_gradient(var, grad_x, grad_y, grad_z, norm, & + ix, iy, iz) + + type(scalar_field), intent(IN) :: var + type(scalar_field), intent(INOUT) :: grad_x + type(scalar_field), intent(INOUT) :: grad_y + type(scalar_field), intent(INOUT) :: grad_z + type(scalar_field), intent(INOUT) :: norm + + integer :: j, k, l !< Generic loop iterators + + type(int_bounds_info) :: ix, iy, iz + + ix%beg = -buff_size; ix%end = m + buff_size; + if (n > 0) then + iy%beg = -buff_size; iy%end = n + buff_size + else + iy%beg = -1; iy%end = 1 + end if + + if (p > 0) then + iz%beg = -buff_size; iz%end = p + buff_size + else + iz%beg = -1; iz%end = 1 + end if + + !$acc update device(ix, iy, iz) + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg + 1, iz%end - 1 + do k = iy%beg + 1, iy%end - 1 + do j = ix%beg + 1, ix%end - 1 + grad_x%sf(j, k, l) = & + (var%sf(j + 1, k, l) - var%sf(j - 1, k, l))/ & + (x_cc(j + 1) - x_cc(j - 1)) + end do + end do + end do + + if (n > 0) then + !$acc parallel loop collapse(3) gang vector + do l = iz%beg + 1, iz%end - 1 + do k = iy%beg + 1, iy%end - 1 + do j = ix%beg + 1, ix%end - 1 + grad_y%sf(j, k, l) = & + (var%sf(j, k + 1, l) - var%sf(j, k - 1, l))/ & + (y_cc(k + 1) - y_cc(k - 1)) + end do + end do + end do + end if + + if (p > 0) then + !$acc parallel loop collapse(3) gang vector + do l = iz%beg + 1, iz%end - 1 + do k = iy%beg + 1, iy%end - 1 + do j = ix%beg + 1, ix%end - 1 + grad_z%sf(j, k, l) = & + (var%sf(j, k, l + 1) - var%sf(j, k, l - 1))/ & + (z_cc(l + 1) - z_cc(l - 1)) + end do + end do + end do + end if + + ix%beg = -buff_size; ix%end = m + buff_size; + if (n > 0) then + iy%beg = -buff_size; iy%end = n + buff_size + else + iy%beg = 0; iy%end = 0 + end if + + if (p > 0) then + iz%beg = -buff_size; iz%end = p + buff_size + else + iz%beg = 0; iz%end = 0 + end if + + !$acc update device(ix, iy, iz) + + !$acc parallel loop collapse(2) gang vector default(present) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + grad_x%sf(ix%beg, k, l) = & + (-3d0*var%sf(ix%beg, k, l) + 4d0*var%sf(ix%beg + 1, k, l) - var%sf(ix%beg + 2, k, l))/ & + (x_cc(ix%beg + 2) - x_cc(ix%beg)) + grad_x%sf(ix%end, k, l) = & + (3d0*var%sf(ix%end, k, l) - 4d0*var%sf(ix%end - 1, k, l) + var%sf(ix%end - 2, k, l))/ & + (x_cc(ix%end) - x_cc(ix%end - 2)) + end do + end do + if (n > 0) then + !$acc parallel loop collapse(2) gang vector default(present) + do l = iz%beg, iz%end + do j = ix%beg, ix%end + grad_y%sf(j, iy%beg, l) = & + (-3d0*var%sf(j, iy%beg, l) + 4d0*var%sf(j, iy%beg + 1, l) - var%sf(j, iy%beg + 2, l))/ & + (y_cc(iy%beg + 2) - y_cc(iy%beg)) + grad_y%sf(j, iy%end, l) = & + (3d0*var%sf(j, iy%end, l) - 4d0*var%sf(j, iy%end - 1, l) + var%sf(j, iy%end - 2, l))/ & + (y_cc(iy%end) - y_cc(iy%end - 2)) + end do + end do + if (p > 0) then + !$acc parallel loop collapse(2) gang vector default(present) + do k = iy%beg, iy%end + do j = ix%beg, ix%end + grad_z%sf(j, k, iz%beg) = & + (-3d0*var%sf(j, k, iz%beg) + 4d0*var%sf(j, k, iz%beg + 1) - var%sf(j, k, iz%beg + 2))/ & + (z_cc(iz%beg + 2) - z_cc(iz%beg)) + grad_z%sf(j, k, iz%end) = & + (3d0*var%sf(j, k, iz%end) - 4d0*var%sf(j, k, iz%end - 1) + var%sf(j, k, iz%end - 2))/ & + (z_cc(iz%end) - z_cc(iz%end - 2)) + end do + end do + end if + end if + + if (bc_x%beg <= -3) then + !$acc parallel loop collapse(2) gang vector default(present) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + grad_x%sf(0, k, l) = (-3d0*var%sf(0, k, l) + 4d0*var%sf(1, k, l) - var%sf(2, k, l))/ & + (x_cc(2) - x_cc(0)) + end do + end do + end if + if (bc_x%end <= -3) then + !$acc parallel loop collapse(2) gang vector default(present) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + grad_x%sf(m, k, l) = (3d0*var%sf(m, k, l) - 4d0*var%sf(m - 1, k, l) + var%sf(m - 2, k, l))/ & + (x_cc(m) - x_cc(m - 2)) + end do + end do + end if + if (n > 0) then + if (bc_y%beg <= -3 .and. bc_y%beg /= -13) then + !$acc parallel loop collapse(2) gang vector default(present) + do l = iz%beg, iz%end + do j = ix%beg, ix%end + grad_y%sf(j, 0, l) = (-3d0*var%sf(j, 0, l) + 4d0*var%sf(j, 1, l) - var%sf(j, 2, l))/ & + (y_cc(2) - y_cc(0)) + end do + end do + end if + if (bc_y%end <= -3) then + !$acc parallel loop collapse(2) gang vector default(present) + do l = iz%beg, iz%end + do j = ix%beg, ix%end + grad_y%sf(j, n, l) = (3d0*var%sf(j, n, l) - 4d0*var%sf(j, n - 1, l) + var%sf(j, n - 2, l))/ & + (y_cc(n) - y_cc(n - 2)) + end do + end do + end if + if (p > 0) then + if (bc_z%beg <= -3) then + !$acc parallel loop collapse(2) gang vector default(present) + do k = iy%beg, iy%end + do j = ix%beg, ix%end + grad_z%sf(j, k, 0) = & + (-3d0*var%sf(j, k, 0) + 4d0*var%sf(j, k, 1) - var%sf(j, k, 2))/ & + (z_cc(2) - z_cc(0)) + end do + end do + end if + if (bc_z%end <= -3) then + !$acc parallel loop collapse(2) gang vector default(present) + do k = iy%beg, iy%end + do j = ix%beg, ix%end + grad_z%sf(j, k, p) = & + (3d0*var%sf(j, k, p) - 4d0*var%sf(j, k, p - 1) + var%sf(j, k, p - 2))/ & + (z_cc(p) - z_cc(p - 2)) + end do + end do + end if + end if + end if + + end subroutine s_compute_fd_gradient ! -------------------------------------- + +!> Computes viscous terms + !! @param q_cons_vf Cell-averaged conservative variables + !! @param q_prim_vf Cell-averaged primitive variables + !! @param rhs_vf Cell-averaged RHS variables + subroutine s_get_viscous(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & + dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, & + qL_prim, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & + dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, & + qR_prim, & + q_prim_qp, & + dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, gm_vel_qp, & + ix, iy, iz) + + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), & + intent(INOUT) :: qL_prim_rsx_vf, qR_prim_rsx_vf, & + qL_prim_rsy_vf, qR_prim_rsy_vf, & + qL_prim_rsz_vf, qR_prim_rsz_vf + + type(vector_field), dimension(sys_size) :: qL_prim, qR_prim + + type(vector_field) :: q_prim_qp + + type(vector_field), dimension(1:num_dims), & + intent(INOUT) :: dqL_prim_dx_n, dqR_prim_dx_n, & + dqL_prim_dy_n, dqR_prim_dy_n, & + dqL_prim_dz_n, dqR_prim_dz_n + + type(vector_field) :: dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp + type(vector_field) :: gm_vel_qp + + integer :: i, j, k, l, r !< Generic loop iterators + type(int_bounds_info), intent(IN) :: ix, iy, iz + + do i = 1, num_dims + + iv%beg = mom_idx%beg; iv%end = mom_idx%end + + !$acc update device(iv) + + call s_reconstruct_cell_boundary_values_visc( & + q_prim_qp%vf(iv%beg:iv%end), & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & + i, qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & + ix, iy, iz) + end do + + if (weno_Re_flux) then + ! Compute velocity gradient at cell centers using scalar + ! divergence theorem + do i = 1, num_dims + if (i == 1) then + call s_apply_scalar_divergence_theorem( & + qL_prim(i)%vf(iv%beg:iv%end), & + qR_prim(i)%vf(iv%beg:iv%end), & + dq_prim_dx_qp%vf(iv%beg:iv%end), i, & + ix, iy, iz) + elseif (i == 2) then + call s_apply_scalar_divergence_theorem( & + qL_prim(i)%vf(iv%beg:iv%end), & + qR_prim(i)%vf(iv%beg:iv%end), & + dq_prim_dy_qp%vf(iv%beg:iv%end), i, & + ix, iy, iz) + else + call s_apply_scalar_divergence_theorem( & + qL_prim(i)%vf(iv%beg:iv%end), & + qR_prim(i)%vf(iv%beg:iv%end), & + dq_prim_dz_qp%vf(iv%beg:iv%end), i, & + ix, iy, iz) + end if + end do + + else ! Compute velocity gradient at cell centers using finite differences + + iv%beg = mom_idx%beg; iv%end = mom_idx%end + !$acc update device(iv) + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg + 1, ix%end + !$acc loop seq + do i = iv%beg, iv%end + dqL_prim_dx_n(1)%vf(i)%sf(j, k, l) = & + (q_prim_qp%vf(i)%sf(j, k, l) - & + q_prim_qp%vf(i)%sf(j - 1, k, l))/ & + (x_cc(j) - x_cc(j - 1)) + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg, ix%end - 1 + !$acc loop seq + do i = iv%beg, iv%end + dqR_prim_dx_n(1)%vf(i)%sf(j, k, l) = & + (q_prim_qp%vf(i)%sf(j + 1, k, l) - & + q_prim_qp%vf(i)%sf(j, k, l))/ & + (x_cc(j + 1) - x_cc(j)) + end do + end do + end do + end do + + if (n > 0) then + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg, iz%end + do j = iy%beg + 1, iy%end + do k = ix%beg, ix%end + !$acc loop seq + do i = iv%beg, iv%end + dqL_prim_dy_n(2)%vf(i)%sf(k, j, l) = & + (q_prim_qp%vf(i)%sf(k, j, l) - & + q_prim_qp%vf(i)%sf(k, j - 1, l))/ & + (y_cc(j) - y_cc(j - 1)) + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg, iz%end + do j = iy%beg, iy%end - 1 + do k = ix%beg, ix%end + !$acc loop seq + do i = iv%beg, iv%end + dqR_prim_dy_n(2)%vf(i)%sf(k, j, l) = & + (q_prim_qp%vf(i)%sf(k, j + 1, l) - & + q_prim_qp%vf(i)%sf(k, j, l))/ & + (y_cc(j + 1) - y_cc(j)) + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg, iz%end + do j = iy%beg + 1, iy%end + do k = ix%beg + 1, ix%end - 1 + !$acc loop seq + do i = iv%beg, iv%end + dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = & + (dqL_prim_dx_n(1)%vf(i)%sf(k, j, l) + & + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l) + & + dqL_prim_dx_n(1)%vf(i)%sf(k, j - 1, l) + & + dqR_prim_dx_n(1)%vf(i)%sf(k, j - 1, l)) + + dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25d-2* & + dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg, iz%end + do j = iy%beg, iy%end - 1 + do k = ix%beg + 1, ix%end - 1 + !$acc loop seq + do i = iv%beg, iv%end + dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = & + (dqL_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + & + dqR_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + & + dqL_prim_dx_n(1)%vf(i)%sf(k, j, l) + & + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l)) + + dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25d-2* & + dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) + + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg, iz%end + do k = iy%beg + 1, iy%end - 1 + do j = ix%beg + 1, ix%end + !$acc loop seq + do i = iv%beg, iv%end + dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = & + (dqL_prim_dy_n(2)%vf(i)%sf(j, k, l) + & + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l) + & + dqL_prim_dy_n(2)%vf(i)%sf(j - 1, k, l) + & + dqR_prim_dy_n(2)%vf(i)%sf(j - 1, k, l)) + + dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25d-2* & + dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) + + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg, iz%end + do k = iy%beg + 1, iy%end - 1 + do j = ix%beg, ix%end - 1 + !$acc loop seq + do i = iv%beg, iv%end + dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = & + (dqL_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + & + dqR_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + & + dqL_prim_dy_n(2)%vf(i)%sf(j, k, l) + & + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l)) + + dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25d-2* & + dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) + + end do + end do + end do + end do + + if (p > 0) then + + !$acc parallel loop collapse(3) gang vector default(present) + do j = iz%beg + 1, iz%end + do l = iy%beg, iy%end + do k = ix%beg, ix%end + !$acc loop seq + do i = iv%beg, iv%end + + dqL_prim_dz_n(3)%vf(i)%sf(k, l, j) = & + (q_prim_qp%vf(i)%sf(k, l, j) - & + q_prim_qp%vf(i)%sf(k, l, j - 1))/ & + (z_cc(j) - z_cc(j - 1)) + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do j = iz%beg, iz%end - 1 + do l = iy%beg, iy%end + do k = ix%beg, ix%end + !$acc loop seq + do i = iv%beg, iv%end + + dqR_prim_dz_n(3)%vf(i)%sf(k, l, j) = & + (q_prim_qp%vf(i)%sf(k, l, j + 1) - & + q_prim_qp%vf(i)%sf(k, l, j))/ & + (z_cc(j + 1) - z_cc(j)) + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg + 1, iz%end - 1 + do k = iy%beg, iy%end + do j = ix%beg + 1, ix%end + !$acc loop seq + do i = iv%beg, iv%end + + dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = & + (dqL_prim_dz_n(3)%vf(i)%sf(j, k, l) + & + dqR_prim_dz_n(3)%vf(i)%sf(j, k, l) + & + dqL_prim_dz_n(3)%vf(i)%sf(j - 1, k, l) + & + dqR_prim_dz_n(3)%vf(i)%sf(j - 1, k, l)) + + dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25d-2* & + dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) + + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg + 1, iz%end - 1 + do k = iy%beg, iy%end + do j = ix%beg, ix%end - 1 + !$acc loop seq + do i = iv%beg, iv%end + + dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = & + (dqL_prim_dz_n(3)%vf(i)%sf(j + 1, k, l) + & + dqR_prim_dz_n(3)%vf(i)%sf(j + 1, k, l) + & + dqL_prim_dz_n(3)%vf(i)%sf(j, k, l) + & + dqR_prim_dz_n(3)%vf(i)%sf(j, k, l)) + + dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25d-2* & + dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) + + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg + 1, iz%end - 1 + do j = iy%beg + 1, iy%end + do k = ix%beg, ix%end + !$acc loop seq + do i = iv%beg, iv%end + + dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = & + (dqL_prim_dz_n(3)%vf(i)%sf(k, j, l) + & + dqR_prim_dz_n(3)%vf(i)%sf(k, j, l) + & + dqL_prim_dz_n(3)%vf(i)%sf(k, j - 1, l) + & + dqR_prim_dz_n(3)%vf(i)%sf(k, j - 1, l)) + + dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25d-2* & + dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) + + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg + 1, iz%end - 1 + do j = iy%beg, iy%end - 1 + do k = ix%beg, ix%end + !$acc loop seq + do i = iv%beg, iv%end + + dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = & + (dqL_prim_dz_n(3)%vf(i)%sf(k, j + 1, l) + & + dqR_prim_dz_n(3)%vf(i)%sf(k, j + 1, l) + & + dqL_prim_dz_n(3)%vf(i)%sf(k, j, l) + & + dqR_prim_dz_n(3)%vf(i)%sf(k, j, l)) + + dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25d-2* & + dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) + + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do j = iz%beg + 1, iz%end + do l = iy%beg + 1, iy%end - 1 + do k = ix%beg, ix%end + !$acc loop seq + do i = iv%beg, iv%end + + dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = & + (dqL_prim_dy_n(2)%vf(i)%sf(k, l, j) + & + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j) + & + dqL_prim_dy_n(2)%vf(i)%sf(k, l, j - 1) + & + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j - 1)) + + dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25d-2* & + dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) + + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do j = iz%beg, iz%end - 1 + do l = iy%beg + 1, iy%end - 1 + do k = ix%beg, ix%end + !$acc loop seq + do i = iv%beg, iv%end + + dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = & + (dqL_prim_dy_n(2)%vf(i)%sf(k, l, j + 1) + & + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j + 1) + & + dqL_prim_dy_n(2)%vf(i)%sf(k, l, j) + & + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j)) + + dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25d-2* & + dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) + + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do j = iz%beg + 1, iz%end + do l = iy%beg, iy%end + do k = ix%beg + 1, ix%end - 1 + !$acc loop seq + do i = iv%beg, iv%end + + dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = & + (dqL_prim_dx_n(1)%vf(i)%sf(k, l, j) + & + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j) + & + dqL_prim_dx_n(1)%vf(i)%sf(k, l, j - 1) + & + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j - 1)) + + dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25d-2* & + dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) + + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do j = iz%beg, iz%end - 1 + do l = iy%beg, iy%end + do k = ix%beg + 1, ix%end - 1 + !$acc loop seq + do i = iv%beg, iv%end + dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = & + (dqL_prim_dx_n(1)%vf(i)%sf(k, l, j + 1) + & + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j + 1) + & + dqL_prim_dx_n(1)%vf(i)%sf(k, l, j) + & + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j)) + + dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25d-2* & + dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) + + end do + end do + end do + end do + + do i = iv%beg, iv%end + call s_compute_fd_gradient(q_prim_qp%vf(i), & + dq_prim_dx_qp%vf(i), & + dq_prim_dy_qp%vf(i), & + dq_prim_dz_qp%vf(i), & + gm_vel_qp%vf(i), & + ix, iy, iz) + end do + + else + + do i = iv%beg, iv%end + call s_compute_fd_gradient(q_prim_qp%vf(i), & + dq_prim_dx_qp%vf(i), & + dq_prim_dy_qp%vf(i), & + dq_prim_dy_qp%vf(i), & + gm_vel_qp%vf(i), & + ix, iy, iz) + end do + + end if + + else + do i = iv%beg, iv%end + call s_compute_fd_gradient(q_prim_qp%vf(i), & + dq_prim_dx_qp%vf(i), & + dq_prim_dx_qp%vf(i), & + dq_prim_dx_qp%vf(i), & + gm_vel_qp%vf(i), & + ix, iy, iz) + end do + + end if + + end if + + end subroutine s_get_viscous + + !> The purpose of this subroutine is to employ the inputted + !! left and right cell-boundary integral-averaged variables + !! to compute the relevant cell-average first-order spatial + !! derivatives in the x-, y- or z-direction by means of the + !! scalar divergence theorem. + !! @param vL_vf Left cell-boundary integral averages + !! @param vR_vf Right cell-boundary integral averages + !! @param dv_ds_vf Cell-average first-order spatial derivatives + !! @param norm_dir Splitting coordinate direction + subroutine s_apply_scalar_divergence_theorem(vL_vf, vR_vf, & ! -------- + dv_ds_vf, & + norm_dir, & + ix, iy, iz) + + type(scalar_field), & + dimension(iv%beg:iv%end), & + intent(IN) :: vL_vf, vR_vf + + type(scalar_field), & + dimension(iv%beg:iv%end), & + intent(INOUT) :: dv_ds_vf + + integer, intent(IN) :: norm_dir + + integer :: i, j, k, l !< Generic loop iterators + + type(int_bounds_info) :: ix, iy, iz + + !$acc update device(ix, iy, iz, iv) + + ! First-Order Spatial Derivatives in x-direction =================== + if (norm_dir == 1) then + + ! A general application of the scalar divergence theorem that + ! utilizes the left and right cell-boundary integral-averages, + ! inside each cell, or an arithmetic mean of these two at the + ! cell-boundaries, to calculate the cell-averaged first-order + ! spatial derivatives inside the cell. + +!$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg + 1, ix%end - 1 +!$acc loop seq + do i = iv%beg, iv%end + + dv_ds_vf(i)%sf(j, k, l) = & + 1d0/dx(j) & + *( & + vR_vf(i)%sf(j, k, l) & + - vL_vf(i)%sf(j, k, l) & + ) + end do + end do + end do + end do + + ! END: First-Order Spatial Derivatives in x-direction ============== + + ! First-Order Spatial Derivatives in y-direction =================== + elseif (norm_dir == 2) then + + ! A general application of the scalar divergence theorem that + ! utilizes the left and right cell-boundary integral-averages, + ! inside each cell, or an arithmetic mean of these two at the + ! cell-boundaries, to calculate the cell-averaged first-order + ! spatial derivatives inside the cell. + +!$acc parallel loop collapse(3) gang vector default(present) + + do l = iz%beg, iz%end + do k = iy%beg + 1, iy%end - 1 + do j = ix%beg, ix%end +!$acc loop seq + do i = iv%beg, iv%end + dv_ds_vf(i)%sf(j, k, l) = & + 1d0/dy(k) & + *( & + vR_vf(i)%sf(j, k, l) & + - vL_vf(i)%sf(j, k, l) & + ) + end do + end do + end do + end do + + ! END: First-Order Spatial Derivatives in y-direction ============== + + ! First-Order Spatial Derivatives in z-direction =================== + else + + ! A general application of the scalar divergence theorem that + ! utilizes the left and right cell-boundary integral-averages, + ! inside each cell, or an arithmetic mean of these two at the + ! cell-boundaries, to calculate the cell-averaged first-order + ! spatial derivatives inside the cell. + +!$acc parallel loop collapse(3) gang vector default(present) + do l = iz%beg + 1, iz%end - 1 + do k = iy%beg, iy%end + do j = ix%beg, ix%end +!$acc loop seq + do i = iv%beg, iv%end + dv_ds_vf(i)%sf(j, k, l) = & + 1d0/dz(l) & + *( & + vR_vf(i)%sf(j, k, l) & + - vL_vf(i)%sf(j, k, l) & + ) + end do + end do + end do + end do + + end if + ! END: First-Order Spatial Derivatives in z-direction ============== + + end subroutine s_apply_scalar_divergence_theorem ! --------------------- + + subroutine s_reconstruct_cell_boundary_values_visc(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, & ! - + norm_dir, vL_prim_vf, vR_prim_vf, ix, iy, iz) + + type(scalar_field), dimension(iv%beg:iv%end), intent(IN) :: v_vf + type(scalar_field), dimension(iv%beg:iv%end), intent(INOUT) :: vL_prim_vf, vR_prim_vf + + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: vL_x, vL_y, vL_z, vR_x, vR_y, vR_z + + integer, intent(IN) :: norm_dir + + integer :: weno_dir !< Coordinate direction of the WENO reconstruction + + integer :: i, j, k, l + + type(int_bounds_info) :: ix, iy, iz + ! Reconstruction in s1-direction =================================== + + if (norm_dir == 1) then + is1 = ix; is2 = iy; is3 = iz + weno_dir = 1; is1%beg = is1%beg + weno_polyn + is1%end = is1%end - weno_polyn + + elseif (norm_dir == 2) then + is1 = iy; is2 = ix; is3 = iz + weno_dir = 2; is1%beg = is1%beg + weno_polyn + is1%end = is1%end - weno_polyn + + else + is1 = iz; is2 = iy; is3 = ix + weno_dir = 3; is1%beg = is1%beg + weno_polyn + is1%end = is1%end - weno_polyn + + end if + + !$acc update device(is1, is2, is3, iv) + + if (n > 0) then + if (p > 0) then + + call s_weno(v_vf(iv%beg:iv%end), & + vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, iv%beg:iv%end), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, iv%beg:iv%end), & + norm_dir, weno_dir, & + is1, is2, is3) + else + call s_weno(v_vf(iv%beg:iv%end), & + vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, :), & + norm_dir, weno_dir, & + is1, is2, is3) + end if + else + + call s_weno(v_vf(iv%beg:iv%end), & + vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, :), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, :), vR_z(:, :, :, :), & + norm_dir, weno_dir, & + is1, is2, is3) + end if + + if (any(Re_size > 0)) then + if (weno_Re_flux) then + if (norm_dir == 2) then +!$acc parallel loop collapse(4) gang vector default(present) + do i = iv%beg, iv%end + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + vL_prim_vf(i)%sf(k, j, l) = vL_y(j, k, l, i) + vR_prim_vf(i)%sf(k, j, l) = vR_y(j, k, l, i) + end do + end do + end do + end do + elseif (norm_dir == 3) then +!$acc parallel loop collapse(4) gang vector default(present) + do i = iv%beg, iv%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + vL_prim_vf(i)%sf(l, k, j) = vL_z(j, k, l, i) + vR_prim_vf(i)%sf(l, k, j) = vR_z(j, k, l, i) + end do + end do + end do + end do + elseif (norm_dir == 1) then +!$acc parallel loop collapse(4) gang vector default(present) + do i = iv%beg, iv%end + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + vL_prim_vf(i)%sf(j, k, l) = vL_x(j, k, l, i) + vR_prim_vf(i)%sf(j, k, l) = vR_x(j, k, l, i) + end do + end do + end do + end do + end if + end if + end if + + ! ================================================================== + + end subroutine s_reconstruct_cell_boundary_values_visc ! -------------------- + + subroutine s_finalize_viscous_module() + deallocate (Res) + end subroutine s_finalize_viscous_module + +end module m_viscous diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 732f79798d..d3ed7ff346 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -28,7 +28,7 @@ module m_weno !implicit none - private; public :: s_initialize_weno_module, s_initialize_weno, s_finalize_weno_module, s_weno_alt + private; public :: s_initialize_weno_module, s_initialize_weno, s_finalize_weno_module, s_weno !> @name The cell-average variables that will be WENO-reconstructed. Formerly, they !! are stored in v_vf. However, they are transferred to v_rs_wsL and v_rs_wsR @@ -38,18 +38,11 @@ module m_weno !! of the characteristic decomposition are stored in custom-constructed WENO- !! stencils (WS) that are annexed to each position of a given scalar field. !> @{ - type(vector_field), allocatable, dimension(:) :: v_rs_ws_x, v_rs_ws_y, v_rs_ws_z + real(kind(0d0)), allocatable, dimension(:, :, :, :) :: v_rs_ws_x, v_rs_ws_y, v_rs_ws_z !> @} - !> @name Left and right WENO-reconstructed values of the cell-average variables. - !! Note that the reshaped property of the variables from which these were - !! obtained, v_rs_wsL and v_rs_wsR, is initially kept. Once the reshaping - !! is undone, the reconstructed values are moved into vL_vf and vR_vf. - !> @{ - type(scalar_field), allocatable, dimension(:) :: vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z - !> @} - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: v_rs_ws_x_flat, v_rs_ws_y_flat, v_rs_ws_z_flat + ! WENO Coefficients ======================================================== @@ -115,8 +108,8 @@ module m_weno real(kind(0d0)) :: test -!$acc declare create(v_rs_ws_x, v_rs_ws_y, v_rs_ws_z, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, & -!$acc v_rs_ws_x_flat, v_rs_ws_y_flat, v_rs_ws_z_flat, & +!$acc declare create( & +!$acc v_rs_ws_x, v_rs_ws_y, v_rs_ws_z, & !$acc poly_coef_cbL_x,poly_coef_cbL_y,poly_coef_cbL_z, & !$acc poly_coef_cbR_x,poly_coef_cbR_y,poly_coef_cbR_z,d_cbL_x, & !$acc d_cbL_y,d_cbL_z,d_cbR_x,d_cbR_y,d_cbR_z,beta_coef_x,beta_coef_y,beta_coef_z, & @@ -163,7 +156,7 @@ contains call s_compute_weno_coefficients(1, is1) - allocate (v_rs_ws_x_flat(is1%beg:is1%end, & + allocate (v_rs_ws_x(is1%beg:is1%end, & is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) ! ================================================================== @@ -195,7 +188,7 @@ contains call s_compute_weno_coefficients(2, is2) - allocate (v_rs_ws_y_flat(is2%beg:is2%end, & + allocate (v_rs_ws_y(is2%beg:is2%end, & is1%beg:is1%end, is3%beg:is3%end, 1:sys_size)) ! ================================================================== @@ -220,7 +213,7 @@ contains call s_compute_weno_coefficients(3, is3) - allocate (v_rs_ws_z_flat(is3%beg:is3%end, & + allocate (v_rs_ws_z(is3%beg:is3%end, & is2%beg:is2%end, is1%beg:is1%end, 1:sys_size)) ! ================================================================== @@ -471,12 +464,12 @@ contains end subroutine s_compute_weno_coefficients ! --------------------------- -subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, vR_rs_vf_x_flat, vR_rs_vf_y_flat, vR_rs_vf_z_flat, & ! ------------------- +subroutine s_weno(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, & ! ------------------- norm_dir, weno_dir, & is1_d, is2_d, is3_d) type(scalar_field), dimension(1:), intent(IN) :: v_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, vR_rs_vf_x_flat, vR_rs_vf_y_flat, vR_rs_vf_z_flat + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z integer, intent(IN) :: norm_dir integer, intent(IN) :: weno_dir type(int_bounds_info), intent(IN) :: is1_d, is2_d, is3_d @@ -516,6 +509,8 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v norm_dir, weno_dir) end if + + if (weno_order == 1) then if (weno_dir == 1) then !$acc parallel loop collapse(4) default(present) @@ -523,8 +518,8 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end - vL_rs_vf_x_flat(j, k, l, i) = v_vf(i)%sf(j, k, l) - vR_rs_vf_x_flat(j, k, l, i) = v_vf(i)%sf(j, k, l) + vL_rs_vf_x(j, k, l, i) = v_vf(i)%sf(j, k, l) + vR_rs_vf_x(j, k, l, i) = v_vf(i)%sf(j, k, l) end do end do end do @@ -536,8 +531,8 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end - vL_rs_vf_y_flat(j, k, l, i) = v_vf(i)%sf(k, j, l) - vR_rs_vf_y_flat(j, k, l, i) = v_vf(i)%sf(k, j, l) + vL_rs_vf_y(j, k, l, i) = v_vf(i)%sf(k, j, l) + vR_rs_vf_y(j, k, l, i) = v_vf(i)%sf(k, j, l) end do end do end do @@ -549,122 +544,18 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end - vL_rs_vf_z_flat(j, k, l, i) = v_vf(i)%sf(l, k, j) - vR_rs_vf_z_flat(j, k, l, i) = v_vf(i)%sf(l, k, j) + vL_rs_vf_z(j, k, l, i) = v_vf(i)%sf(l, k, j) + vR_rs_vf_z(j, k, l, i) = v_vf(i)%sf(l, k, j) end do end do end do end do !$acc end parallel loop end if - elseif (weno_order == 3) then - if (weno_dir == 1) then - if (mapped_weno) then -!$acc parallel loop collapse(4) gang vector default(present) private(beta,dvd,poly,omega,alpha) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - do i = 1, v_size - ! reconstruct from left side - - dvd(0) = v_rs_ws_x_flat(j + 1, k, l, i) & - - v_rs_ws_x_flat(j, k, l, i) - dvd(-1) = v_rs_ws_x_flat(j, k, l, i) & - - v_rs_ws_x_flat(j - 1, k, l, i) - - poly(0) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbL_x(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbL_x(j, 1, 0)*dvd(-1) - - beta(0) = beta_coef_x(j, 0, 0)*dvd(0)*dvd(0) & - + weno_eps - beta(1) = beta_coef_x(j, 1, 0)*dvd(-1)*dvd(-1) & - + weno_eps - - alpha = d_cbL_x(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - alpha = (d_cbL_x(:, j)*(1d0 + d_cbL_x(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbL_x(:, j)**2d0 + omega*(1d0 - 2d0*d_cbL_x(:, j)))) - - omega = alpha/sum(alpha) - - vL_rs_vf_x_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) - ! reconstruct from right side - - poly(0) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbR_x(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbR_x(j, 1, 0)*dvd(-1) - - alpha = d_cbR_x(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - alpha = (d_cbR_x(:, j)*(1d0 + d_cbR_x(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbR_x(:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_x(:, j)))) - - omega = alpha/sum(alpha) - - vR_rs_vf_x_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) - - end do - end do - end do - end do -!$acc end parallel loop - else -!$acc parallel loop collapse(4) gang vector default(present) private(beta,dvd,poly,omega,alpha) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - do i = 1, v_size - ! reconstruct from left side - - dvd(0) = v_rs_ws_x_flat(j + 1, k, l, i) & - - v_rs_ws_x_flat(j, k, l, i) - dvd(-1) = v_rs_ws_x_flat(j, k, l, i) & - - v_rs_ws_x_flat(j - 1, k, l, i) - - poly(0) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbL_x(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbL_x(j, 1, 0)*dvd(-1) - - beta(0) = beta_coef_x(j, 0, 0)*dvd(0)*dvd(0) & - + weno_eps - beta(1) = beta_coef_x(j, 1, 0)*dvd(-1)*dvd(-1) & - + weno_eps - - alpha = d_cbL_x(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - vL_rs_vf_x_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) - - ! reconstruct from right side - - poly(0) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbR_x(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbR_x(j, 1, 0)*dvd(-1) - - alpha = d_cbR_x(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - vR_rs_vf_x_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) - - end do - end do - end do - end do -!$acc end parallel loop - end if - elseif (weno_dir == 2) then + elseif (weno_order == 3) then + #:for WENO_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + if (weno_dir == ${WENO_DIR}$) then if (mapped_weno) then !$acc parallel loop collapse(4) gang vector default(present) private(beta,dvd,poly,omega,alpha) do l = is3%beg, is3%end @@ -673,49 +564,49 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v do i = 1, v_size ! reconstruct from left side - dvd(0) = v_rs_ws_y_flat(j + 1, k, l, i) & - - v_rs_ws_y_flat(j, k, l, i) - dvd(-1) = v_rs_ws_y_flat(j, k, l, i) & - - v_rs_ws_y_flat(j - 1, k, l, i) + dvd(0) = v_rs_ws_${XYZ}$(j + 1, k, l, i) & + - v_rs_ws_${XYZ}$(j, k, l, i) + dvd(-1) = v_rs_ws_${XYZ}$(j, k, l, i) & + - v_rs_ws_${XYZ}$(j - 1, k, l, i) - poly(0) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbL_y(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbL_y(j, 1, 0)*dvd(-1) + poly(0) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbL_${XYZ}$(j, 0, 0)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbL_${XYZ}$(j, 1, 0)*dvd(-1) - beta(0) = beta_coef_y(j, 0, 0)*dvd(0)*dvd(0) & + beta(0) = beta_coef_${XYZ}$(j, 0, 0)*dvd(0)*dvd(0) & + weno_eps - beta(1) = beta_coef_y(j, 1, 0)*dvd(-1)*dvd(-1) & + beta(1) = beta_coef_${XYZ}$(j, 1, 0)*dvd(-1)*dvd(-1) & + weno_eps - alpha = d_cbL_y(:, j)/(beta*beta) + alpha = d_cbL_${XYZ}$(:, j)/(beta*beta) omega = alpha/sum(alpha) - alpha = (d_cbL_y(:, j)*(1d0 + d_cbL_y(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbL_y(:, j)**2d0 + omega*(1d0 - 2d0*d_cbL_y(:, j)))) + alpha = (d_cbL_${XYZ}$(:, j)*(1d0 + d_cbL_${XYZ}$(:, j) - 3d0*omega) + omega**2d0) & + *(omega/(d_cbL_${XYZ}$(:, j)**2d0 + omega*(1d0 - 2d0*d_cbL_${XYZ}$(:, j)))) omega = alpha/sum(alpha) - vL_rs_vf_y_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) + vL_rs_vf_${XYZ}$(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) ! reconstruct from right side - poly(0) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbR_y(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbR_y(j, 1, 0)*dvd(-1) + poly(0) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbR_${XYZ}$(j, 0, 0)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbR_${XYZ}$(j, 1, 0)*dvd(-1) - alpha = d_cbR_y(:, j)/(beta*beta) + alpha = d_cbR_${XYZ}$(:, j)/(beta*beta) omega = alpha/sum(alpha) - alpha = (d_cbR_y(:, j)*(1d0 + d_cbR_y(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbR_y(:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_y(:, j)))) + alpha = (d_cbR_${XYZ}$(:, j)*(1d0 + d_cbR_${XYZ}$(:, j) - 3d0*omega) + omega**2d0) & + *(omega/(d_cbR_${XYZ}$(:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_${XYZ}$(:, j)))) omega = alpha/sum(alpha) - vR_rs_vf_y_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) + vR_rs_vf_${XYZ}$(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) end do end do @@ -730,141 +621,39 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v do i = 1, v_size ! reconstruct from left side - dvd(0) = v_rs_ws_y_flat(j + 1, k, l, i) & - - v_rs_ws_y_flat(j, k, l, i) - dvd(-1) = v_rs_ws_y_flat(j, k, l, i) & - - v_rs_ws_y_flat(j - 1, k, l, i) + dvd(0) = v_rs_ws_${XYZ}$(j + 1, k, l, i) & + - v_rs_ws_${XYZ}$(j, k, l, i) + dvd(-1) = v_rs_ws_${XYZ}$(j, k, l, i) & + - v_rs_ws_${XYZ}$(j - 1, k, l, i) - poly(0) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbL_y(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbL_y(j, 1, 0)*dvd(-1) + poly(0) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbL_${XYZ}$(j, 0, 0)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbL_${XYZ}$(j, 1, 0)*dvd(-1) - beta(0) = beta_coef_y(j, 0, 0)*dvd(0)*dvd(0) & + beta(0) = beta_coef_${XYZ}$(j, 0, 0)*dvd(0)*dvd(0) & + weno_eps - beta(1) = beta_coef_y(j, 1, 0)*dvd(-1)*dvd(-1) & + beta(1) = beta_coef_${XYZ}$(j, 1, 0)*dvd(-1)*dvd(-1) & + weno_eps - alpha = d_cbL_y(:, j)/(beta*beta) + alpha = d_cbL_${XYZ}$(:, j)/(beta*beta) omega = alpha/sum(alpha) - vL_rs_vf_y_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) + vL_rs_vf_${XYZ}$(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) ! reconstruct from right side - poly(0) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbR_y(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbR_y(j, 1, 0)*dvd(-1) + poly(0) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbR_${XYZ}$(j, 0, 0)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbR_${XYZ}$(j, 1, 0)*dvd(-1) - alpha = d_cbR_y(:, j)/(beta*beta) + alpha = d_cbR_${XYZ}$(:, j)/(beta*beta) omega = alpha/sum(alpha) - vR_rs_vf_y_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) - - end do - end do - end do - end do -!$acc end parallel loop - end if - else - if (mapped_weno) then -!$acc parallel loop collapse(4) gang vector default(present) private(beta,dvd,poly,omega,alpha) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - do i = 1, v_size - ! reconstruct from left side - - dvd(0) = v_rs_ws_z_flat(j + 1, k, l, i) & - - v_rs_ws_z_flat(j, k, l, i) - dvd(-1) = v_rs_ws_z_flat(j, k, l, i) & - - v_rs_ws_z_flat(j - 1, k, l, i) - - poly(0) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbL_z(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbL_z(j, 1, 0)*dvd(-1) - - beta(0) = beta_coef_z(j, 0, 0)*dvd(0)*dvd(0) & - + weno_eps - beta(1) = beta_coef_z(j, 1, 0)*dvd(-1)*dvd(-1) & - + weno_eps - - alpha = d_cbL_z(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - alpha = (d_cbL_z(:, j)*(1d0 + d_cbL_z(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbL_z(:, j)**2d0 + omega*(1d0 - 2d0*d_cbL_z(:, j)))) - - omega = alpha/sum(alpha) - - vL_rs_vf_z_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) - - poly(0) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbR_z(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbR_z(j, 1, 0)*dvd(-1) - - alpha = d_cbR_z(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - alpha = (d_cbR_z(:, j)*(1d0 + d_cbR_z(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbR_z(:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_z(:, j)))) - - omega = alpha/sum(alpha) - - vR_rs_vf_z_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) - - end do - end do - end do - end do -!$acc end parallel loop - else -!$acc parallel loop collapse(4) gang vector default(present) private(beta,dvd,poly,omega,alpha) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - do i = 1, v_size - ! reconstruct from left side - - dvd(0) = v_rs_ws_z_flat(j + 1, k, l, i) & - - v_rs_ws_z_flat(j, k, l, i) - dvd(-1) = v_rs_ws_z_flat(j, k, l, i) & - - v_rs_ws_z_flat(j - 1, k, l, i) - - poly(0) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbL_z(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbL_z(j, 1, 0)*dvd(-1) - - beta(0) = beta_coef_z(j, 0, 0)*dvd(0)*dvd(0) & - + weno_eps - beta(1) = beta_coef_z(j, 1, 0)*dvd(-1)*dvd(-1) & - + weno_eps - - alpha = d_cbL_z(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - vL_rs_vf_z_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) - - poly(0) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbR_z(j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbR_z(j, 1, 0)*dvd(-1) - - alpha = d_cbR_z(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - vR_rs_vf_z_flat(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) + vR_rs_vf_${XYZ}$(j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) end do end do @@ -873,298 +662,10 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v !$acc end parallel loop end if end if + #:endfor else - if (weno_dir == 1) then - if (mapped_weno) then -!$acc parallel loop gang vector collapse (3) default(present) private(dvd, poly, beta, alpha, omega) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end -!$acc loop seq - do i = 1, v_size - - dvd(1) = v_rs_ws_x_flat(j + 2, k, l, i) & - - v_rs_ws_x_flat(j + 1, k, l, i) - dvd(0) = v_rs_ws_x_flat(j + 1, k, l, i) & - - v_rs_ws_x_flat(j, k, l, i) - dvd(-1) = v_rs_ws_x_flat(j, k, l, i) & - - v_rs_ws_x_flat(j - 1, k, l, i) - dvd(-2) = v_rs_ws_x_flat(j - 1, k, l, i) & - - v_rs_ws_x_flat(j - 2, k, l, i) - - poly(0) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbL_x(j, 0, 0)*dvd(1) & - + poly_coef_cbL_x(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbL_x(j, 1, 0)*dvd(0) & - + poly_coef_cbL_x(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbL_x(j, 2, 0)*dvd(-1) & - + poly_coef_cbL_x(j, 2, 1)*dvd(-2) - - beta(0) = beta_coef_x(j, 0, 0)*dvd(1)*dvd(1) & - + beta_coef_x(j, 0, 1)*dvd(1)*dvd(0) & - + beta_coef_x(j, 0, 2)*dvd(0)*dvd(0) & - + weno_eps - beta(1) = beta_coef_x(j, 1, 0)*dvd(0)*dvd(0) & - + beta_coef_x(j, 1, 1)*dvd(0)*dvd(-1) & - + beta_coef_x(j, 1, 2)*dvd(-1)*dvd(-1) & - + weno_eps - beta(2) = beta_coef_x(j, 2, 0)*dvd(-1)*dvd(-1) & - + beta_coef_x(j, 2, 1)*dvd(-1)*dvd(-2) & - + beta_coef_x(j, 2, 2)*dvd(-2)*dvd(-2) & - + weno_eps - - alpha = d_cbL_x(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - !if (mapped_weno) then - !call s_map_nonlinear_weights(d_cbL_x(:, j), & - !alpha, & - !omega) - - alpha = (d_cbL_x(:, j)*(1d0 + d_cbL_x(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbL_x(:, j)**2d0 + omega*(1d0 - 2d0*d_cbL_x(:, j)))) - - omega = alpha/sum(alpha) - !end if - - vL_rs_vf_x_flat(j, k, l, i) = sum(omega*poly) - - poly(0) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbR_x(j, 0, 0)*dvd(1) & - + poly_coef_cbR_x(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbR_x(j, 1, 0)*dvd(0) & - + poly_coef_cbR_x(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbR_x(j, 2, 0)*dvd(-1) & - + poly_coef_cbR_x(j, 2, 1)*dvd(-2) - - alpha = d_cbR_x(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - !if (mapped_weno) then - !call s_map_nonlinear_weights(d_cbR_x(:, j), & - !alpha, & - !omega) - !end if - - alpha = (d_cbR_x(:, j)*(1d0 + d_cbR_x(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbR_x(:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_x(:, j)))) - - omega = alpha/sum(alpha) - - vR_rs_vf_x_flat(j, k, l, i) = sum(omega*poly) - - end do - end do - end do - end do -!$acc end parallel loop - else -!$acc parallel loop gang vector collapse (4) default(present) private(dvd, poly, beta, alpha, omega) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - do i = 1, v_size - - dvd(1) = v_rs_ws_x_flat(j + 2, k, l, i) & - - v_rs_ws_x_flat(j + 1, k, l, i) - dvd(0) = v_rs_ws_x_flat(j + 1, k, l, i) & - - v_rs_ws_x_flat(j, k, l, i) - dvd(-1) = v_rs_ws_x_flat(j, k, l, i) & - - v_rs_ws_x_flat(j - 1, k, l, i) - dvd(-2) = v_rs_ws_x_flat(j - 1, k, l, i) & - - v_rs_ws_x_flat(j - 2, k, l, i) - - poly(0) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbL_x(j, 0, 0)*dvd(1) & - + poly_coef_cbL_x(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbL_x(j, 1, 0)*dvd(0) & - + poly_coef_cbL_x(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbL_x(j, 2, 0)*dvd(-1) & - + poly_coef_cbL_x(j, 2, 1)*dvd(-2) - - beta(0) = beta_coef_x(j, 0, 0)*dvd(1)*dvd(1) & - + beta_coef_x(j, 0, 1)*dvd(1)*dvd(0) & - + beta_coef_x(j, 0, 2)*dvd(0)*dvd(0) & - + weno_eps - beta(1) = beta_coef_x(j, 1, 0)*dvd(0)*dvd(0) & - + beta_coef_x(j, 1, 1)*dvd(0)*dvd(-1) & - + beta_coef_x(j, 1, 2)*dvd(-1)*dvd(-1) & - + weno_eps - beta(2) = beta_coef_x(j, 2, 0)*dvd(-1)*dvd(-1) & - + beta_coef_x(j, 2, 1)*dvd(-1)*dvd(-2) & - + beta_coef_x(j, 2, 2)*dvd(-2)*dvd(-2) & - + weno_eps - - alpha = d_cbL_x(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - vL_rs_vf_x_flat(j, k, l, i) = sum(omega*poly) - - poly(0) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbR_x(j, 0, 0)*dvd(1) & - + poly_coef_cbR_x(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbR_x(j, 1, 0)*dvd(0) & - + poly_coef_cbR_x(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_x_flat(j, k, l, i) & - + poly_coef_cbR_x(j, 2, 0)*dvd(-1) & - + poly_coef_cbR_x(j, 2, 1)*dvd(-2) - - alpha = d_cbR_x(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - vR_rs_vf_x_flat(j, k, l, i) = sum(omega*poly) - - end do - end do - end do - end do -!$acc end parallel loop - end if - - if (mp_weno) then -!$acc parallel loop gang vector collapse (4) default(present) private(d) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - do i = 1, v_size - alpha_mp = 2d0 - beta_mp = 4d0/3d0 - - d(-1) = v_rs_ws_x_flat(j, k, l, i) & - + v_rs_ws_x_flat(j - 2, k, l, i) & - - v_rs_ws_x_flat(j - 1, k, l, i) & - *2d0 - d(0) = v_rs_ws_x_flat(j + 1, k, l, i) & - + v_rs_ws_x_flat(j - 1, k, l, i) & - - v_rs_ws_x_flat(j, k, l, i) & - *2d0 - d(1) = v_rs_ws_x_flat(j + 2, k, l, i) & - + v_rs_ws_x_flat(j, k, l, i) & - - v_rs_ws_x_flat(j + 1, k, l, i) & - *2d0 - - d_MD = (sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, 4d0*d(0) - d(-1))) & - *abs((sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(-1))) & - *(sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(0)))) & - *min(abs(4d0*d(-1) - d(0)), abs(d(-1)), & - abs(4d0*d(0) - d(-1)), abs(d(0)))/8d0 - - d_LC = (sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, 4d0*d(1) - d(0))) & - *abs((sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(0))) & - *(sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(1)))) & - *min(abs(4d0*d(0) - d(1)), abs(d(0)), & - abs(4d0*d(1) - d(0)), abs(d(1)))/8d0 - - vL_UL = v_rs_ws_x_flat(j, k, l, i) & - - (v_rs_ws_x_flat(j + 1, k, l, i) & - - v_rs_ws_x_flat(j, k, l, i))*alpha_mp - - vL_MD = (v_rs_ws_x_flat(j, k, l, i) & - + v_rs_ws_x_flat(j - 1, k, l, i) & - - d_MD)*5d-1 - - vL_LC = v_rs_ws_x_flat(j, k, l, i) & - - (v_rs_ws_x_flat(j + 1, k, l, i) & - - v_rs_ws_x_flat(j, k, l, i))*5d-1 + beta_mp*d_LC - - vL_min = max(min(v_rs_ws_x_flat(j, k, l, i), & - v_rs_ws_x_flat(j - 1, k, l, i), & - vL_MD), & - min(v_rs_ws_x_flat(j, k, l, i), & - vL_UL, & - vL_LC)) - - vL_max = min(max(v_rs_ws_x_flat(j, k, l, i), & - v_rs_ws_x_flat(j - 1, k, l, i), & - vL_MD), & - max(v_rs_ws_x_flat(j, k, l, i), & - vL_UL, & - vL_LC)) - - vL_rs_vf_x_flat(j, k, l, i) = vL_rs_vf_x_flat(j, k, l, i) & - + (sign(5d-1, vL_min - vL_rs_vf_x_flat(j, k, l, i)) & - + sign(5d-1, vL_max - vL_rs_vf_x_flat(j, k, l, i))) & - *min(abs(vL_min - vL_rs_vf_x_flat(j, k, l, i)), & - abs(vL_max - vL_rs_vf_x_flat(j, k, l, i))) - ! END: Left Monotonicity Preserving Bound ========================== - - ! Right Monotonicity Preserving Bound ============================== - d(-1) = v_rs_ws_x_flat(j, k, l, i) & - + v_rs_ws_x_flat(j - 2, k, l, i) & - - v_rs_ws_x_flat(j - 1, k, l, i) & - *2d0 - d(0) = v_rs_ws_x_flat(j + 1, k, l, i) & - + v_rs_ws_x_flat(j - 1, k, l, i) & - - v_rs_ws_x_flat(j, k, l, i) & - *2d0 - d(1) = v_rs_ws_x_flat(j + 2, k, l, i) & - + v_rs_ws_x_flat(j, k, l, i) & - - v_rs_ws_x_flat(j + 1, k, l, i) & - *2d0 - - d_MD = (sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, 4d0*d(1) - d(0))) & - *abs((sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(0))) & - *(sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(1)))) & - *min(abs(4d0*d(0) - d(1)), abs(d(0)), & - abs(4d0*d(1) - d(0)), abs(d(1)))/8d0 - - d_LC = (sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, 4d0*d(0) - d(-1))) & - *abs((sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(-1))) & - *(sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(0)))) & - *min(abs(4d0*d(-1) - d(0)), abs(d(-1)), & - abs(4d0*d(0) - d(-1)), abs(d(0)))/8d0 - - vR_UL = v_rs_ws_x_flat(j, k, l, i) & - + (v_rs_ws_x_flat(j, k, l, i) & - - v_rs_ws_x_flat(j - 1, k, l, i))*alpha_mp - - vR_MD = (v_rs_ws_x_flat(j, k, l, i) & - + v_rs_ws_x_flat(j + 1, k, l, i) & - - d_MD)*5d-1 - - vR_LC = v_rs_ws_x_flat(j, k, l, i) & - + (v_rs_ws_x_flat(j, k, l, i) & - - v_rs_ws_x_flat(j - 1, k, l, i))*5d-1 + beta_mp*d_LC - - vR_min = max(min(v_rs_ws_x_flat(j, k, l, i), & - v_rs_ws_x_flat(j + 1, k, l, i), & - vR_MD), & - min(v_rs_ws_x_flat(j, k, l, i), & - vR_UL, & - vR_LC)) - - vR_max = min(max(v_rs_ws_x_flat(j, k, l, i), & - v_rs_ws_x_flat(j + 1, k, l, i), & - vR_MD), & - max(v_rs_ws_x_flat(j, k, l, i), & - vR_UL, & - vR_LC)) - - vR_rs_vf_x_flat(j, k, l, i) = vR_rs_vf_x_flat(j, k, l, i) & - + (sign(5d-1, vR_min - vR_rs_vf_x_flat(j, k, l, i)) & - + sign(5d-1, vR_max - vR_rs_vf_x_flat(j, k, l, i))) & - *min(abs(vR_min - vR_rs_vf_x_flat(j, k, l, i)), & - abs(vR_max - vR_rs_vf_x_flat(j, k, l, i))) - ! END: Right Monotonicity Preserving Bound ========================= - end do - end do - end do - end do -!$acc end parallel loop - end if - - elseif (weno_dir == 2) then + #:for WENO_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + if (weno_dir == ${WENO_DIR}$) then if (mapped_weno) then !$acc parallel loop gang vector collapse (3) default(present) private(dvd, poly, beta, alpha, omega) do l = is3%beg, is3%end @@ -1173,355 +674,72 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v !$acc loop seq do i = 1, v_size - dvd(1) = v_rs_ws_y_flat(j + 2, k, l, i) & - - v_rs_ws_y_flat(j + 1, k, l, i) - dvd(0) = v_rs_ws_y_flat(j + 1, k, l, i) & - - v_rs_ws_y_flat(j, k, l, i) - dvd(-1) = v_rs_ws_y_flat(j, k, l, i) & - - v_rs_ws_y_flat(j - 1, k, l, i) - dvd(-2) = v_rs_ws_y_flat(j - 1, k, l, i) & - - v_rs_ws_y_flat(j - 2, k, l, i) - - poly(0) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbL_y(j, 0, 0)*dvd(1) & - + poly_coef_cbL_y(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbL_y(j, 1, 0)*dvd(0) & - + poly_coef_cbL_y(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbL_y(j, 2, 0)*dvd(-1) & - + poly_coef_cbL_y(j, 2, 1)*dvd(-2) - - beta(0) = beta_coef_y(j, 0, 0)*dvd(1)*dvd(1) & - + beta_coef_y(j, 0, 1)*dvd(1)*dvd(0) & - + beta_coef_y(j, 0, 2)*dvd(0)*dvd(0) & + dvd(1) = v_rs_ws_${XYZ}$(j + 2, k, l, i) & + - v_rs_ws_${XYZ}$(j + 1, k, l, i) + dvd(0) = v_rs_ws_${XYZ}$(j + 1, k, l, i) & + - v_rs_ws_${XYZ}$(j, k, l, i) + dvd(-1) = v_rs_ws_${XYZ}$(j, k, l, i) & + - v_rs_ws_${XYZ}$(j - 1, k, l, i) + dvd(-2) = v_rs_ws_${XYZ}$(j - 1, k, l, i) & + - v_rs_ws_${XYZ}$(j - 2, k, l, i) + + poly(0) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbL_${XYZ}$(j, 0, 0)*dvd(1) & + + poly_coef_cbL_${XYZ}$(j, 0, 1)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbL_${XYZ}$(j, 1, 0)*dvd(0) & + + poly_coef_cbL_${XYZ}$(j, 1, 1)*dvd(-1) + poly(2) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbL_${XYZ}$(j, 2, 0)*dvd(-1) & + + poly_coef_cbL_${XYZ}$(j, 2, 1)*dvd(-2) + + beta(0) = beta_coef_${XYZ}$(j, 0, 0)*dvd(1)*dvd(1) & + + beta_coef_${XYZ}$(j, 0, 1)*dvd(1)*dvd(0) & + + beta_coef_${XYZ}$(j, 0, 2)*dvd(0)*dvd(0) & + weno_eps - beta(1) = beta_coef_y(j, 1, 0)*dvd(0)*dvd(0) & - + beta_coef_y(j, 1, 1)*dvd(0)*dvd(-1) & - + beta_coef_y(j, 1, 2)*dvd(-1)*dvd(-1) & + beta(1) = beta_coef_${XYZ}$(j, 1, 0)*dvd(0)*dvd(0) & + + beta_coef_${XYZ}$(j, 1, 1)*dvd(0)*dvd(-1) & + + beta_coef_${XYZ}$(j, 1, 2)*dvd(-1)*dvd(-1) & + weno_eps - beta(2) = beta_coef_y(j, 2, 0)*dvd(-1)*dvd(-1) & - + beta_coef_y(j, 2, 1)*dvd(-1)*dvd(-2) & - + beta_coef_y(j, 2, 2)*dvd(-2)*dvd(-2) & + beta(2) = beta_coef_${XYZ}$(j, 2, 0)*dvd(-1)*dvd(-1) & + + beta_coef_${XYZ}$(j, 2, 1)*dvd(-1)*dvd(-2) & + + beta_coef_${XYZ}$(j, 2, 2)*dvd(-2)*dvd(-2) & + weno_eps - alpha = d_cbL_y(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - !if (mapped_weno) then - alpha = (d_cbL_y(:, j)*(1d0 + d_cbL_y(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbL_y(:, j)**2d0 + omega*(1d0 - 2d0*d_cbL_y(:, j)))) - - omega = alpha/sum(alpha) - !end if - - vL_rs_vf_y_flat(j, k, l, i) = sum(omega*poly) - - poly(0) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbR_y(j, 0, 0)*dvd(1) & - + poly_coef_cbR_y(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbR_y(j, 1, 0)*dvd(0) & - + poly_coef_cbR_y(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbR_y(j, 2, 0)*dvd(-1) & - + poly_coef_cbR_y(j, 2, 1)*dvd(-2) - - alpha = d_cbR_y(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - !if (mapped_weno) then - alpha = (d_cbR_y(:, j)*(1d0 + d_cbR_y(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbR_y(:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_y(:, j)))) - - omega = alpha/sum(alpha) - !end if - - vR_rs_vf_y_flat(j, k, l, i) = sum(omega*poly) - - end do - end do - end do - end do -!$acc end parallel loop - else -!$acc parallel loop gang vector collapse (4) default(present) private(dvd, poly, beta, alpha, omega) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - do i = 1, v_size - - dvd(1) = v_rs_ws_y_flat(j + 2, k, l, i) & - - v_rs_ws_y_flat(j + 1, k, l, i) - dvd(0) = v_rs_ws_y_flat(j + 1, k, l, i) & - - v_rs_ws_y_flat(j, k, l, i) - dvd(-1) = v_rs_ws_y_flat(j, k, l, i) & - - v_rs_ws_y_flat(j - 1, k, l, i) - dvd(-2) = v_rs_ws_y_flat(j - 1, k, l, i) & - - v_rs_ws_y_flat(j - 2, k, l, i) - - poly(0) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbL_y(j, 0, 0)*dvd(1) & - + poly_coef_cbL_y(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbL_y(j, 1, 0)*dvd(0) & - + poly_coef_cbL_y(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbL_y(j, 2, 0)*dvd(-1) & - + poly_coef_cbL_y(j, 2, 1)*dvd(-2) - - beta(0) = beta_coef_y(j, 0, 0)*dvd(1)*dvd(1) & - + beta_coef_y(j, 0, 1)*dvd(1)*dvd(0) & - + beta_coef_y(j, 0, 2)*dvd(0)*dvd(0) & - + weno_eps - beta(1) = beta_coef_y(j, 1, 0)*dvd(0)*dvd(0) & - + beta_coef_y(j, 1, 1)*dvd(0)*dvd(-1) & - + beta_coef_y(j, 1, 2)*dvd(-1)*dvd(-1) & - + weno_eps - beta(2) = beta_coef_y(j, 2, 0)*dvd(-1)*dvd(-1) & - + beta_coef_y(j, 2, 1)*dvd(-1)*dvd(-2) & - + beta_coef_y(j, 2, 2)*dvd(-2)*dvd(-2) & - + weno_eps - - alpha = d_cbL_y(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - vL_rs_vf_y_flat(j, k, l, i) = sum(omega*poly) - - poly(0) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbR_y(j, 0, 0)*dvd(1) & - + poly_coef_cbR_y(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbR_y(j, 1, 0)*dvd(0) & - + poly_coef_cbR_y(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_y_flat(j, k, l, i) & - + poly_coef_cbR_y(j, 2, 0)*dvd(-1) & - + poly_coef_cbR_y(j, 2, 1)*dvd(-2) - - alpha = d_cbR_y(:, j)/(beta*beta) + alpha = d_cbL_${XYZ}$(:, j)/(beta*beta) omega = alpha/sum(alpha) - vR_rs_vf_y_flat(j, k, l, i) = sum(omega*poly) - - end do - end do - end do - end do -!$acc end parallel loop - end if - - if (mp_weno) then -!$acc parallel loop gang vector collapse (4) default(present) private(d) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - do i = 1, v_size - alpha_mp = 2d0 - beta_mp = 4d0/3d0 - - d(-1) = v_rs_ws_y_flat(j, k, l, i) & - + v_rs_ws_y_flat(j - 2, k, l, i) & - - v_rs_ws_y_flat(j - 1, k, l, i) & - *2d0 - d(0) = v_rs_ws_y_flat(j + 1, k, l, i) & - + v_rs_ws_y_flat(j - 1, k, l, i) & - - v_rs_ws_y_flat(j, k, l, i) & - *2d0 - d(1) = v_rs_ws_y_flat(j + 2, k, l, i) & - + v_rs_ws_y_flat(j, k, l, i) & - - v_rs_ws_y_flat(j + 1, k, l, i) & - *2d0 - - d_MD = (sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, 4d0*d(0) - d(-1))) & - *abs((sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(-1))) & - *(sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(0)))) & - *min(abs(4d0*d(-1) - d(0)), abs(d(-1)), & - abs(4d0*d(0) - d(-1)), abs(d(0)))/8d0 - - d_LC = (sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, 4d0*d(1) - d(0))) & - *abs((sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(0))) & - *(sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(1)))) & - *min(abs(4d0*d(0) - d(1)), abs(d(0)), & - abs(4d0*d(1) - d(0)), abs(d(1)))/8d0 - - vL_UL = v_rs_ws_y_flat(j, k, l, i) & - - (v_rs_ws_y_flat(j + 1, k, l, i) & - - v_rs_ws_y_flat(j, k, l, i))*alpha_mp - - vL_MD = (v_rs_ws_y_flat(j, k, l, i) & - + v_rs_ws_y_flat(j - 1, k, l, i) & - - d_MD)*5d-1 - - vL_LC = v_rs_ws_y_flat(j, k, l, i) & - - (v_rs_ws_y_flat(j + 1, k, l, i) & - - v_rs_ws_y_flat(j, k, l, i))*5d-1 + beta_mp*d_LC - - vL_min = max(min(v_rs_ws_y_flat(j, k, l, i), & - v_rs_ws_y_flat(j - 1, k, l, i), & - vL_MD), & - min(v_rs_ws_y_flat(j, k, l, i), & - vL_UL, & - vL_LC)) - - vL_max = min(max(v_rs_ws_y_flat(j, k, l, i), & - v_rs_ws_y_flat(j - 1, k, l, i), & - vL_MD), & - max(v_rs_ws_y_flat(j, k, l, i), & - vL_UL, & - vL_LC)) - - vL_rs_vf_y_flat(j, k, l, i) = vL_rs_vf_y_flat(j, k, l, i) & - + (sign(5d-1, vL_min - vL_rs_vf_y_flat(j, k, l, i)) & - + sign(5d-1, vL_max - vL_rs_vf_y_flat(j, k, l, i))) & - *min(abs(vL_min - vL_rs_vf_y_flat(j, k, l, i)), & - abs(vL_max - vL_rs_vf_y_flat(j, k, l, i))) - ! END: Left Monotonicity Preserving Bound ========================== - - ! Right Monotonicity Preserving Bound ============================== - d(-1) = v_rs_ws_y_flat(j, k, l, i) & - + v_rs_ws_y_flat(j - 2, k, l, i) & - - v_rs_ws_y_flat(j - 1, k, l, i) & - *2d0 - d(0) = v_rs_ws_y_flat(j + 1, k, l, i) & - + v_rs_ws_y_flat(j - 1, k, l, i) & - - v_rs_ws_y_flat(j, k, l, i) & - *2d0 - d(1) = v_rs_ws_y_flat(j + 2, k, l, i) & - + v_rs_ws_y_flat(j, k, l, i) & - - v_rs_ws_y_flat(j + 1, k, l, i) & - *2d0 - - d_MD = (sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, 4d0*d(1) - d(0))) & - *abs((sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(0))) & - *(sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(1)))) & - *min(abs(4d0*d(0) - d(1)), abs(d(0)), & - abs(4d0*d(1) - d(0)), abs(d(1)))/8d0 - - d_LC = (sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, 4d0*d(0) - d(-1))) & - *abs((sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(-1))) & - *(sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(0)))) & - *min(abs(4d0*d(-1) - d(0)), abs(d(-1)), & - abs(4d0*d(0) - d(-1)), abs(d(0)))/8d0 - - vR_UL = v_rs_ws_y_flat(j, k, l, i) & - + (v_rs_ws_y_flat(j, k, l, i) & - - v_rs_ws_y_flat(j - 1, k, l, i))*alpha_mp - - vR_MD = (v_rs_ws_y_flat(j, k, l, i) & - + v_rs_ws_y_flat(j + 1, k, l, i) & - - d_MD)*5d-1 - - vR_LC = v_rs_ws_y_flat(j, k, l, i) & - + (v_rs_ws_y_flat(j, k, l, i) & - - v_rs_ws_y_flat(j - 1, k, l, i))*5d-1 + beta_mp*d_LC - - vR_min = max(min(v_rs_ws_y_flat(j, k, l, i), & - v_rs_ws_y_flat(j + 1, k, l, i), & - vR_MD), & - min(v_rs_ws_y_flat(j, k, l, i), & - vR_UL, & - vR_LC)) - - vR_max = min(max(v_rs_ws_y_flat(j, k, l, i), & - v_rs_ws_y_flat(j + 1, k, l, i), & - vR_MD), & - max(v_rs_ws_y_flat(j, k, l, i), & - vR_UL, & - vR_LC)) - - vR_rs_vf_y_flat(j, k, l, i) = vR_rs_vf_y_flat(j, k, l, i) & - + (sign(5d-1, vR_min - vR_rs_vf_y_flat(j, k, l, i)) & - + sign(5d-1, vR_max - vR_rs_vf_y_flat(j, k, l, i))) & - *min(abs(vR_min - vR_rs_vf_y_flat(j, k, l, i)), & - abs(vR_max - vR_rs_vf_y_flat(j, k, l, i))) - ! END: Right Monotonicity Preserving Bound ========================= - end do - end do - end do - end do -!$acc end parallel loop - end if - - else - if (mapped_weno) then -!$acc parallel loop gang vector collapse (3) default(present) private(dvd, poly, beta, alpha, omega) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end -!$acc loop seq - do i = 1, v_size - - dvd(1) = v_rs_ws_z_flat(j + 2, k, l, i) & - - v_rs_ws_z_flat(j + 1, k, l, i) - dvd(0) = v_rs_ws_z_flat(j + 1, k, l, i) & - - v_rs_ws_z_flat(j, k, l, i) - dvd(-1) = v_rs_ws_z_flat(j, k, l, i) & - - v_rs_ws_z_flat(j - 1, k, l, i) - dvd(-2) = v_rs_ws_z_flat(j - 1, k, l, i) & - - v_rs_ws_z_flat(j - 2, k, l, i) - - poly(0) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbL_z(j, 0, 0)*dvd(1) & - + poly_coef_cbL_z(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbL_z(j, 1, 0)*dvd(0) & - + poly_coef_cbL_z(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbL_z(j, 2, 0)*dvd(-1) & - + poly_coef_cbL_z(j, 2, 1)*dvd(-2) - - beta(0) = beta_coef_z(j, 0, 0)*dvd(1)*dvd(1) & - + beta_coef_z(j, 0, 1)*dvd(1)*dvd(0) & - + beta_coef_z(j, 0, 2)*dvd(0)*dvd(0) & - + weno_eps - beta(1) = beta_coef_z(j, 1, 0)*dvd(0)*dvd(0) & - + beta_coef_z(j, 1, 1)*dvd(0)*dvd(-1) & - + beta_coef_z(j, 1, 2)*dvd(-1)*dvd(-1) & - + weno_eps - beta(2) = beta_coef_z(j, 2, 0)*dvd(-1)*dvd(-1) & - + beta_coef_z(j, 2, 1)*dvd(-1)*dvd(-2) & - + beta_coef_z(j, 2, 2)*dvd(-2)*dvd(-2) & - + weno_eps - - alpha = d_cbL_z(:, j)/(beta*beta) - - omega = alpha/sum(alpha) + - !if (mapped_weno) then - alpha = (d_cbL_z(:, j)*(1d0 + d_cbL_z(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbL_z(:, j)**2d0 + omega*(1d0 - 2d0*d_cbL_z(:, j)))) + alpha = (d_cbL_${XYZ}$(:, j)*(1d0 + d_cbL_${XYZ}$(:, j) - 3d0*omega) + omega**2d0) & + *(omega/(d_cbL_${XYZ}$(:, j)**2d0 + omega*(1d0 - 2d0*d_cbL_${XYZ}$(:, j)))) omega = alpha/sum(alpha) - !end if + - vL_rs_vf_z_flat(j, k, l, i) = sum(omega*poly) + vL_rs_vf_${XYZ}$(j, k, l, i) = sum(omega*poly) - poly(0) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbR_z(j, 0, 0)*dvd(1) & - + poly_coef_cbR_z(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbR_z(j, 1, 0)*dvd(0) & - + poly_coef_cbR_z(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbR_z(j, 2, 0)*dvd(-1) & - + poly_coef_cbR_z(j, 2, 1)*dvd(-2) + poly(0) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbR_${XYZ}$(j, 0, 0)*dvd(1) & + + poly_coef_cbR_${XYZ}$(j, 0, 1)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbR_${XYZ}$(j, 1, 0)*dvd(0) & + + poly_coef_cbR_${XYZ}$(j, 1, 1)*dvd(-1) + poly(2) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbR_${XYZ}$(j, 2, 0)*dvd(-1) & + + poly_coef_cbR_${XYZ}$(j, 2, 1)*dvd(-2) - alpha = d_cbR_z(:, j)/(beta*beta) + alpha = d_cbR_${XYZ}$(:, j)/(beta*beta) omega = alpha/sum(alpha) - !if (mapped_weno) then - alpha = (d_cbR_z(:, j)*(1d0 + d_cbR_z(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbR_z(:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_z(:, j)))) + alpha = (d_cbR_${XYZ}$(:, j)*(1d0 + d_cbR_${XYZ}$(:, j) - 3d0*omega) + omega**2d0) & + *(omega/(d_cbR_${XYZ}$(:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_${XYZ}$(:, j)))) omega = alpha/sum(alpha) - !end if - vR_rs_vf_z_flat(j, k, l, i) = sum(omega*poly) + vR_rs_vf_${XYZ}$(j, k, l, i) = sum(omega*poly) end do end do @@ -1535,59 +753,59 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v do j = is1%beg, is1%end do i = 1, v_size - dvd(1) = v_rs_ws_z_flat(j + 2, k, l, i) & - - v_rs_ws_z_flat(j + 1, k, l, i) - dvd(0) = v_rs_ws_z_flat(j + 1, k, l, i) & - - v_rs_ws_z_flat(j, k, l, i) - dvd(-1) = v_rs_ws_z_flat(j, k, l, i) & - - v_rs_ws_z_flat(j - 1, k, l, i) - dvd(-2) = v_rs_ws_z_flat(j - 1, k, l, i) & - - v_rs_ws_z_flat(j - 2, k, l, i) - - poly(0) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbL_z(j, 0, 0)*dvd(1) & - + poly_coef_cbL_z(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbL_z(j, 1, 0)*dvd(0) & - + poly_coef_cbL_z(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbL_z(j, 2, 0)*dvd(-1) & - + poly_coef_cbL_z(j, 2, 1)*dvd(-2) - - beta(0) = beta_coef_z(j, 0, 0)*dvd(1)*dvd(1) & - + beta_coef_z(j, 0, 1)*dvd(1)*dvd(0) & - + beta_coef_z(j, 0, 2)*dvd(0)*dvd(0) & + dvd(1) = v_rs_ws_${XYZ}$(j + 2, k, l, i) & + - v_rs_ws_${XYZ}$(j + 1, k, l, i) + dvd(0) = v_rs_ws_${XYZ}$(j + 1, k, l, i) & + - v_rs_ws_${XYZ}$(j, k, l, i) + dvd(-1) = v_rs_ws_${XYZ}$(j, k, l, i) & + - v_rs_ws_${XYZ}$(j - 1, k, l, i) + dvd(-2) = v_rs_ws_${XYZ}$(j - 1, k, l, i) & + - v_rs_ws_${XYZ}$(j - 2, k, l, i) + + poly(0) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbL_${XYZ}$(j, 0, 0)*dvd(1) & + + poly_coef_cbL_${XYZ}$(j, 0, 1)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbL_${XYZ}$(j, 1, 0)*dvd(0) & + + poly_coef_cbL_${XYZ}$(j, 1, 1)*dvd(-1) + poly(2) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbL_${XYZ}$(j, 2, 0)*dvd(-1) & + + poly_coef_cbL_${XYZ}$(j, 2, 1)*dvd(-2) + + beta(0) = beta_coef_${XYZ}$(j, 0, 0)*dvd(1)*dvd(1) & + + beta_coef_${XYZ}$(j, 0, 1)*dvd(1)*dvd(0) & + + beta_coef_${XYZ}$(j, 0, 2)*dvd(0)*dvd(0) & + weno_eps - beta(1) = beta_coef_z(j, 1, 0)*dvd(0)*dvd(0) & - + beta_coef_z(j, 1, 1)*dvd(0)*dvd(-1) & - + beta_coef_z(j, 1, 2)*dvd(-1)*dvd(-1) & + beta(1) = beta_coef_${XYZ}$(j, 1, 0)*dvd(0)*dvd(0) & + + beta_coef_${XYZ}$(j, 1, 1)*dvd(0)*dvd(-1) & + + beta_coef_${XYZ}$(j, 1, 2)*dvd(-1)*dvd(-1) & + weno_eps - beta(2) = beta_coef_z(j, 2, 0)*dvd(-1)*dvd(-1) & - + beta_coef_z(j, 2, 1)*dvd(-1)*dvd(-2) & - + beta_coef_z(j, 2, 2)*dvd(-2)*dvd(-2) & + beta(2) = beta_coef_${XYZ}$(j, 2, 0)*dvd(-1)*dvd(-1) & + + beta_coef_${XYZ}$(j, 2, 1)*dvd(-1)*dvd(-2) & + + beta_coef_${XYZ}$(j, 2, 2)*dvd(-2)*dvd(-2) & + weno_eps - alpha = d_cbL_z(:, j)/(beta*beta) + alpha = d_cbL_${XYZ}$(:, j)/(beta*beta) omega = alpha/sum(alpha) - vL_rs_vf_z_flat(j, k, l, i) = sum(omega*poly) + vL_rs_vf_${XYZ}$(j, k, l, i) = sum(omega*poly) - poly(0) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbR_z(j, 0, 0)*dvd(1) & - + poly_coef_cbR_z(j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbR_z(j, 1, 0)*dvd(0) & - + poly_coef_cbR_z(j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_z_flat(j, k, l, i) & - + poly_coef_cbR_z(j, 2, 0)*dvd(-1) & - + poly_coef_cbR_z(j, 2, 1)*dvd(-2) + poly(0) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbR_${XYZ}$(j, 0, 0)*dvd(1) & + + poly_coef_cbR_${XYZ}$(j, 0, 1)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbR_${XYZ}$(j, 1, 0)*dvd(0) & + + poly_coef_cbR_${XYZ}$(j, 1, 1)*dvd(-1) + poly(2) = v_rs_ws_${XYZ}$(j, k, l, i) & + + poly_coef_cbR_${XYZ}$(j, 2, 0)*dvd(-1) & + + poly_coef_cbR_${XYZ}$(j, 2, 1)*dvd(-2) - alpha = d_cbR_z(:, j)/(beta*beta) + alpha = d_cbR_${XYZ}$(:, j)/(beta*beta) omega = alpha/sum(alpha) - vR_rs_vf_z_flat(j, k, l, i) = sum(omega*poly) + vR_rs_vf_${XYZ}$(j, k, l, i) = sum(omega*poly) end do end do @@ -1605,17 +823,17 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v alpha_mp = 2d0 beta_mp = 4d0/3d0 - d(-1) = v_rs_ws_z_flat(j, k, l, i) & - + v_rs_ws_z_flat(j - 2, k, l, i) & - - v_rs_ws_z_flat(j - 1, k, l, i) & + d(-1) = v_rs_ws_${XYZ}$(j, k, l, i) & + + v_rs_ws_${XYZ}$(j - 2, k, l, i) & + - v_rs_ws_${XYZ}$(j - 1, k, l, i) & *2d0 - d(0) = v_rs_ws_z_flat(j + 1, k, l, i) & - + v_rs_ws_z_flat(j - 1, k, l, i) & - - v_rs_ws_z_flat(j, k, l, i) & + d(0) = v_rs_ws_${XYZ}$(j + 1, k, l, i) & + + v_rs_ws_${XYZ}$(j - 1, k, l, i) & + - v_rs_ws_${XYZ}$(j, k, l, i) & *2d0 - d(1) = v_rs_ws_z_flat(j + 2, k, l, i) & - + v_rs_ws_z_flat(j, k, l, i) & - - v_rs_ws_z_flat(j + 1, k, l, i) & + d(1) = v_rs_ws_${XYZ}$(j + 2, k, l, i) & + + v_rs_ws_${XYZ}$(j, k, l, i) & + - v_rs_ws_${XYZ}$(j + 1, k, l, i) & *2d0 d_MD = (sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, 4d0*d(0) - d(-1))) & @@ -1630,51 +848,51 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v *min(abs(4d0*d(0) - d(1)), abs(d(0)), & abs(4d0*d(1) - d(0)), abs(d(1)))/8d0 - vL_UL = v_rs_ws_z_flat(j, k, l, i) & - - (v_rs_ws_z_flat(j + 1, k, l, i) & - - v_rs_ws_z_flat(j, k, l, i))*alpha_mp + vL_UL = v_rs_ws_${XYZ}$(j, k, l, i) & + - (v_rs_ws_${XYZ}$(j + 1, k, l, i) & + - v_rs_ws_${XYZ}$(j, k, l, i))*alpha_mp - vL_MD = (v_rs_ws_z_flat(j, k, l, i) & - + v_rs_ws_z_flat(j - 1, k, l, i) & + vL_MD = (v_rs_ws_${XYZ}$(j, k, l, i) & + + v_rs_ws_${XYZ}$(j - 1, k, l, i) & - d_MD)*5d-1 - vL_LC = v_rs_ws_z_flat(j, k, l, i) & - - (v_rs_ws_z_flat(j + 1, k, l, i) & - - v_rs_ws_z_flat(j, k, l, i))*5d-1 + beta_mp*d_LC + vL_LC = v_rs_ws_${XYZ}$(j, k, l, i) & + - (v_rs_ws_${XYZ}$(j + 1, k, l, i) & + - v_rs_ws_${XYZ}$(j, k, l, i))*5d-1 + beta_mp*d_LC - vL_min = max(min(v_rs_ws_z_flat(j, k, l, i), & - v_rs_ws_z_flat(j - 1, k, l, i), & + vL_min = max(min(v_rs_ws_${XYZ}$(j, k, l, i), & + v_rs_ws_${XYZ}$(j - 1, k, l, i), & vL_MD), & - min(v_rs_ws_z_flat(j, k, l, i), & + min(v_rs_ws_${XYZ}$(j, k, l, i), & vL_UL, & vL_LC)) - vL_max = min(max(v_rs_ws_z_flat(j, k, l, i), & - v_rs_ws_z_flat(j - 1, k, l, i), & + vL_max = min(max(v_rs_ws_${XYZ}$(j, k, l, i), & + v_rs_ws_${XYZ}$(j - 1, k, l, i), & vL_MD), & - max(v_rs_ws_z_flat(j, k, l, i), & + max(v_rs_ws_${XYZ}$(j, k, l, i), & vL_UL, & vL_LC)) - vL_rs_vf_z_flat(j, k, l, i) = vL_rs_vf_z_flat(j, k, l, i) & - + (sign(5d-1, vL_min - vL_rs_vf_z_flat(j, k, l, i)) & - + sign(5d-1, vL_max - vL_rs_vf_z_flat(j, k, l, i))) & - *min(abs(vL_min - vL_rs_vf_z_flat(j, k, l, i)), & - abs(vL_max - vL_rs_vf_z_flat(j, k, l, i))) + vL_rs_vf_${XYZ}$(j, k, l, i) = vL_rs_vf_${XYZ}$(j, k, l, i) & + + (sign(5d-1, vL_min - vL_rs_vf_${XYZ}$(j, k, l, i)) & + + sign(5d-1, vL_max - vL_rs_vf_${XYZ}$(j, k, l, i))) & + *min(abs(vL_min - vL_rs_vf_${XYZ}$(j, k, l, i)), & + abs(vL_max - vL_rs_vf_${XYZ}$(j, k, l, i))) ! END: Left Monotonicity Preserving Bound ========================== ! Right Monotonicity Preserving Bound ============================== - d(-1) = v_rs_ws_z_flat(j, k, l, i) & - + v_rs_ws_z_flat(j - 2, k, l, i) & - - v_rs_ws_z_flat(j - 1, k, l, i) & + d(-1) = v_rs_ws_${XYZ}$(j, k, l, i) & + + v_rs_ws_${XYZ}$(j - 2, k, l, i) & + - v_rs_ws_${XYZ}$(j - 1, k, l, i) & *2d0 - d(0) = v_rs_ws_z_flat(j + 1, k, l, i) & - + v_rs_ws_z_flat(j - 1, k, l, i) & - - v_rs_ws_z_flat(j, k, l, i) & + d(0) = v_rs_ws_${XYZ}$(j + 1, k, l, i) & + + v_rs_ws_${XYZ}$(j - 1, k, l, i) & + - v_rs_ws_${XYZ}$(j, k, l, i) & *2d0 - d(1) = v_rs_ws_z_flat(j + 2, k, l, i) & - + v_rs_ws_z_flat(j, k, l, i) & - - v_rs_ws_z_flat(j + 1, k, l, i) & + d(1) = v_rs_ws_${XYZ}$(j + 2, k, l, i) & + + v_rs_ws_${XYZ}$(j, k, l, i) & + - v_rs_ws_${XYZ}$(j + 1, k, l, i) & *2d0 d_MD = (sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, 4d0*d(1) - d(0))) & @@ -1689,37 +907,37 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v *min(abs(4d0*d(-1) - d(0)), abs(d(-1)), & abs(4d0*d(0) - d(-1)), abs(d(0)))/8d0 - vR_UL = v_rs_ws_z_flat(j, k, l, i) & - + (v_rs_ws_z_flat(j, k, l, i) & - - v_rs_ws_z_flat(j - 1, k, l, i))*alpha_mp + vR_UL = v_rs_ws_${XYZ}$(j, k, l, i) & + + (v_rs_ws_${XYZ}$(j, k, l, i) & + - v_rs_ws_${XYZ}$(j - 1, k, l, i))*alpha_mp - vR_MD = (v_rs_ws_z_flat(j, k, l, i) & - + v_rs_ws_z_flat(j + 1, k, l, i) & + vR_MD = (v_rs_ws_${XYZ}$(j, k, l, i) & + + v_rs_ws_${XYZ}$(j + 1, k, l, i) & - d_MD)*5d-1 - vR_LC = v_rs_ws_z_flat(j, k, l, i) & - + (v_rs_ws_z_flat(j, k, l, i) & - - v_rs_ws_z_flat(j - 1, k, l, i))*5d-1 + beta_mp*d_LC + vR_LC = v_rs_ws_${XYZ}$(j, k, l, i) & + + (v_rs_ws_${XYZ}$(j, k, l, i) & + - v_rs_ws_${XYZ}$(j - 1, k, l, i))*5d-1 + beta_mp*d_LC - vR_min = max(min(v_rs_ws_z_flat(j, k, l, i), & - v_rs_ws_z_flat(j + 1, k, l, i), & + vR_min = max(min(v_rs_ws_${XYZ}$(j, k, l, i), & + v_rs_ws_${XYZ}$(j + 1, k, l, i), & vR_MD), & - min(v_rs_ws_z_flat(j, k, l, i), & + min(v_rs_ws_${XYZ}$(j, k, l, i), & vR_UL, & vR_LC)) - vR_max = min(max(v_rs_ws_z_flat(j, k, l, i), & - v_rs_ws_z_flat(j + 1, k, l, i), & + vR_max = min(max(v_rs_ws_${XYZ}$(j, k, l, i), & + v_rs_ws_${XYZ}$(j + 1, k, l, i), & vR_MD), & - max(v_rs_ws_z_flat(j, k, l, i), & + max(v_rs_ws_${XYZ}$(j, k, l, i), & vR_UL, & vR_LC)) - vR_rs_vf_z_flat(j, k, l, i) = vR_rs_vf_z_flat(j, k, l, i) & - + (sign(5d-1, vR_min - vR_rs_vf_z_flat(j, k, l, i)) & - + sign(5d-1, vR_max - vR_rs_vf_z_flat(j, k, l, i))) & - *min(abs(vR_min - vR_rs_vf_z_flat(j, k, l, i)), & - abs(vR_max - vR_rs_vf_z_flat(j, k, l, i))) + vR_rs_vf_${XYZ}$(j, k, l, i) = vR_rs_vf_${XYZ}$(j, k, l, i) & + + (sign(5d-1, vR_min - vR_rs_vf_${XYZ}$(j, k, l, i)) & + + sign(5d-1, vR_max - vR_rs_vf_${XYZ}$(j, k, l, i))) & + *min(abs(vR_min - vR_rs_vf_${XYZ}$(j, k, l, i)), & + abs(vR_max - vR_rs_vf_${XYZ}$(j, k, l, i))) ! END: Right Monotonicity Preserving Bound ========================= end do end do @@ -1728,9 +946,11 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v !$acc end parallel loop end if end if + #:endfor end if + - end subroutine s_weno_alt + end subroutine s_weno !> The computation of parameters, the allocation of memory, !! the association of pointers and/or the execution of any @@ -1769,7 +989,7 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v do q = is3%beg, is3%end do l = is2%beg, is2%end do k = is1%beg - weno_polyn, is1%end + weno_polyn - v_rs_ws_x_flat(k, l, q, j) = v_vf(j)%sf(k, l, q) + v_rs_ws_x(k, l, q, j) = v_vf(j)%sf(k, l, q) end do end do end do @@ -1789,16 +1009,16 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v block use CuTensorEx - !$acc host_data use_device(v_rs_ws_x_flat, v_rs_ws_y_flat) - v_rs_ws_y_flat = reshape(v_rs_ws_x_flat, shape=[n + 1 + 2*buff_size, m + 2*buff_size + 1, p + 1, sys_size], order=[2, 1, 3, 4]) + !$acc host_data use_device(v_rs_ws_x, v_rs_ws_y) + v_rs_ws_y = reshape(v_rs_ws_x, shape=[n + 1 + 2*buff_size, m + 2*buff_size + 1, p + 1, sys_size], order=[2, 1, 3, 4]) !$acc end host_data end block else block use CuTensorEx - !$acc host_data use_device(v_rs_ws_x_flat, v_rs_ws_y_flat) - v_rs_ws_y_flat = reshape(v_rs_ws_x_flat, shape = [n+1+2*buff_size, m+2*buff_size+1,p+1+2*buff_size,sys_size], order = [2, 1, 3, 4]) + !$acc host_data use_device(v_rs_ws_x, v_rs_ws_y) + v_rs_ws_y = reshape(v_rs_ws_x, shape = [n+1+2*buff_size, m+2*buff_size+1,p+1+2*buff_size,sys_size], order = [2, 1, 3, 4]) !$acc end host_data end block end if @@ -1809,7 +1029,7 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v do q = is3%beg, is3%end do l = is2%beg, is2%end do k = is1%beg - weno_polyn, is1%end + weno_polyn - v_rs_ws_y_flat(k, l, q, j) = v_vf(j)%sf(l, k, q) + v_rs_ws_y(k, l, q, j) = v_vf(j)%sf(l, k, q) end do end do end do @@ -1830,8 +1050,8 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v block use CuTensorEx - !$acc host_data use_device(v_rs_ws_x_flat, v_rs_ws_z_flat) - v_rs_ws_z_flat = reshape(v_rs_ws_x_flat, shape = [p+1+2*buff_size, n+2*buff_size+1,m+2*buff_size+1,sys_size], order = [3, 2, 1, 4]) + !$acc host_data use_device(v_rs_ws_x, v_rs_ws_z) + v_rs_ws_z = reshape(v_rs_ws_x, shape = [p+1+2*buff_size, n+2*buff_size+1,m+2*buff_size+1,sys_size], order = [3, 2, 1, 4]) !$acc end host_data end block else @@ -1841,7 +1061,7 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v do q = is3%beg, is3%end do l = is2%beg, is2%end do k = is1%beg - weno_polyn, is1%end + weno_polyn - v_rs_ws_z_flat(k, l, q, j) = v_vf(j)%sf(q, l, k) + v_rs_ws_z(k, l, q, j) = v_vf(j)%sf(q, l, k) end do end do end do @@ -2068,8 +1288,8 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v ! Deallocating the WENO-stencil of the WENO-reconstructed variables - !deallocate(vL_rs_vf_x_flat, vR_rs_vf_x_flat) - deallocate (v_rs_ws_x_flat) + !deallocate(vL_rs_vf_x, vR_rs_vf_x) + deallocate (v_rs_ws_x) ! Deallocating WENO coefficients in x-direction ==================== deallocate (poly_coef_cbL_x, poly_coef_cbR_x) @@ -2080,8 +1300,8 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v ! Deallocating WENO coefficients in y-direction ==================== if (n == 0) return - !deallocate(vL_rs_vf_y_flat, vR_rs_vf_y_flat) - deallocate (v_rs_ws_y_flat) + !deallocate(vL_rs_vf_y, vR_rs_vf_y) + deallocate (v_rs_ws_y) deallocate (poly_coef_cbL_y, poly_coef_cbR_y) deallocate (d_cbL_y, d_cbR_y) @@ -2091,8 +1311,8 @@ subroutine s_weno_alt(v_vf, vL_rs_vf_x_flat, vL_rs_vf_y_flat, vL_rs_vf_z_flat, v ! Deallocating WENO coefficients in z-direction ==================== if (p == 0) return - !deallocate(vL_rs_vf_z_flat, vR_rs_vf_z_flat) - deallocate (v_rs_ws_z_flat) + !deallocate(vL_rs_vf_z, vR_rs_vf_z) + deallocate (v_rs_ws_z) deallocate (poly_coef_cbL_z, poly_coef_cbR_z) deallocate (d_cbL_z, d_cbR_z) diff --git a/src/simulation/p_main.fpp b/src/simulation/p_main.fpp index 1ed4f280a1..7c258ac489 100644 --- a/src/simulation/p_main.fpp +++ b/src/simulation/p_main.fpp @@ -33,6 +33,8 @@ program p_main use m_cbc !< Characteristic boundary conditions (CBC) + use m_monopole !< Monopole calculations + use m_rhs !< Right-hand-side (RHS) evaluation procedures use m_data_output !< Run-time info & solution data output procedures @@ -46,6 +48,10 @@ program p_main use m_hypoelastic + use m_viscous + + use m_bubbles + #ifdef _OPENACC use openacc #endif @@ -141,12 +147,20 @@ program p_main call s_initialize_start_up_module() call s_initialize_riemann_solvers_module() + if(bubbles) call s_initialize_bubbles_module() + if (qbmm) call s_initialize_qbmm_module() #if defined(_OPENACC) && defined(MFC_MEMORY_DUMP) call acc_present_dump() #endif // defined(_OPENACC) && defined(MFC_MEMORY_DUMP) + if (monopole) then + call s_initialize_monopole_module() + end if + if (any(Re_size > 1)) then + call s_initialize_viscous_module() + end if call s_initialize_rhs_module() #if defined(_OPENACC) && defined(MFC_MEMORY_DUMP) @@ -343,6 +357,10 @@ program p_main call s_finalize_mpi_proxy_module() call s_finalize_global_parameters_module() + if (any(Re_size > 0)) then + call s_finalize_viscous_module() + end if + ! Terminating MPI execution environment call s_mpi_finalize() diff --git a/toolchain/mfc/tests/tests.py b/toolchain/mfc/tests/tests.py index c242beedad..41fa39b7c5 100644 --- a/toolchain/mfc/tests/tests.py +++ b/toolchain/mfc/tests/tests.py @@ -154,7 +154,6 @@ def handle_case(self, test: Case): pack.save(os.path.join(test.get_dirpath(), "pack.txt")) golden_filepath = os.path.join(test.get_dirpath(), "golden.txt") - if self.mfc.args["generate"]: common.delete_file(golden_filepath) pack.save(golden_filepath)