diff --git a/.github/workflows/pretty.yml b/.github/workflows/pretty.yml new file mode 100644 index 000000000..4c37aeb59 --- /dev/null +++ b/.github/workflows/pretty.yml @@ -0,0 +1,21 @@ +name: Pretty + +on: + push: + + pull_request: + + workflow_dispatch: + +jobs: + docs: + name: Code formatting + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v3 + + - name: Check formatting + run: | + ./mfc.sh format + git diff --exit-code diff --git a/src/common/include/inline_conversions.fpp b/src/common/include/inline_conversions.fpp index fa1b25543..9811290a8 100644 --- a/src/common/include/inline_conversions.fpp +++ b/src/common/include/inline_conversions.fpp @@ -12,19 +12,19 @@ integer :: q - 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 q = 1, num_fluids - c = c + adv(q)*(1d0/gammas(q) + 1d0)* & - (pres + pi_infs(q)/(gammas(q) + 1d0)) - end do + 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 q = 1, num_fluids + c = c + adv(q)*(1d0/gammas(q) + 1d0)* & + (pres + pi_infs(q)/(gammas(q) + 1d0)) + end do c = c/rho elseif (((model_eqns == 4) .or. (model_eqns == 2 .and. bubbles))) then @@ -32,17 +32,17 @@ if (mpp_lim .and. (num_fluids > 1)) then c = (1d0/gamma + 1d0)* & - (pres + pi_inf/(gamma+1d0))/rho + (pres + pi_inf/(gamma + 1d0))/rho else c = & - (1d0/gamma + 1d0)* & - (pres + pi_inf/(gamma + 1d0)) / & - (rho * (1d0 - adv(num_fluids))) + (1d0/gamma + 1d0)* & + (pres + pi_inf/(gamma + 1d0))/ & + (rho*(1d0 - adv(num_fluids))) end if - else - c = ((H - 5d-1*vel_sum)/gamma) - end if + else + c = ((H - 5d-1*vel_sum)/gamma) + end if if (mixture_err .and. c < 0d0) then c = 100.d0*sgm_eps diff --git a/src/common/include/macros.fpp b/src/common/include/macros.fpp index 1966a0b09..2f2d2fcf6 100644 --- a/src/common/include/macros.fpp +++ b/src/common/include/macros.fpp @@ -4,24 +4,24 @@ use iso_fortran_env, only: output_unit print *, '${_FILE_.split('/')[-1]}$:${_LINE_}$: ', ${expr}$ - call flush(output_unit) + call flush (output_unit) end block #endif #:enddef #:def ALLOCATE(*args) @:LOG({'@:ALLOCATE(${re.sub(' +', ' ', ', '.join(args))}$)'}) - allocate(${', '.join(args)}$) + allocate (${', '.join(args)}$) #:if MFC_COMPILER == 'Cray' - !$acc enter data create(${', '.join([ arg.split('(')[0] for arg in args ])}$) + !$acc enter data create(${', '.join([ arg.split('(')[0] for arg in args ])}$) #:else - !$acc enter data create(${', '.join(args)}$) + !$acc enter data create(${', '.join(args)}$) #:endif #:enddef ALLOCATE #:def DEALLOCATE(*args) @:LOG({'@:DEALLOCATE(${re.sub(' +', ' ', ', '.join(args))}$)'}) - deallocate(${', '.join(args)}$) + deallocate (${', '.join(args)}$) !$acc exit data delete(${', '.join(args)}$) #:enddef DEALLOCATE diff --git a/src/common/m_compile_specific.f90 b/src/common/m_compile_specific.f90 index 9b33901dd..72d141b23 100644 --- a/src/common/m_compile_specific.f90 +++ b/src/common/m_compile_specific.f90 @@ -70,10 +70,10 @@ subroutine s_get_cwd(cwd) end subroutine s_get_cwd subroutine s_get_basename(dirpath, basename) - character(LEN=*), intent(IN) :: dirpath + character(LEN=*), intent(IN) :: dirpath character(LEN=*), intent(OUT) :: basename - integer :: iUnit + integer :: iUnit character(len=30) :: tmpfilepath write (tmpfilepath, '(A,I0)') 'basename_', proc_rank @@ -84,8 +84,8 @@ subroutine s_get_basename(dirpath, basename) call system('basename "'//trim(dirpath)//'" > '//trim(tmpfilepath)) #endif - open (newunit=iUnit, FILE=trim(tmpfilepath), FORM='formatted', STATUS='old') - read (iUnit, '(A)') basename + open (newunit=iUnit, FILE=trim(tmpfilepath), FORM='formatted', STATUS='old') + read (iUnit, '(A)') basename close (iUnit) call s_delete_file(trim(tmpfilepath)) diff --git a/src/common/m_constants.fpp b/src/common/m_constants.fpp index 5cce70b0b..adf0ee3c0 100644 --- a/src/common/m_constants.fpp +++ b/src/common/m_constants.fpp @@ -5,22 +5,22 @@ module m_constants character, parameter :: dflt_char = ' ' !< Default string value - + real(kind(0d0)), parameter :: dflt_real = -1d6 !< Default real value - real(kind(0d0)), parameter :: sgm_eps = 1d-16 !< Segmentation tolerance + real(kind(0d0)), parameter :: sgm_eps = 1d-16 !< Segmentation tolerance real(kind(0d0)), parameter :: small_alf = 1d-7 !< Small alf tolerance - real(kind(0d0)), parameter :: pi = 3.141592653589793d0 !< Pi + real(kind(0d0)), parameter :: pi = 3.141592653589793d0 !< Pi real(kind(0d0)), parameter :: verysmall = 1.d-12 !< Very small number - - integer, parameter :: num_stcls_min = 5 !< Minimum # of stencils - integer, parameter :: path_len = 400 !< Maximum path length - integer, parameter :: name_len = 50 !< Maximum name length - integer, parameter :: dflt_int = -100 !< Default integer value - integer, parameter :: fourier_rings = 5 !< Fourier filter ring limit - integer, parameter :: num_fluids_max = 10 !< Maximum number of fluids in the simulation - integer, parameter :: num_probes_max = 10 !< Maximum number of flow probes in the simulation + + integer, parameter :: num_stcls_min = 5 !< Minimum # of stencils + integer, parameter :: path_len = 400 !< Maximum path length + integer, parameter :: name_len = 50 !< Maximum name length + integer, parameter :: dflt_int = -100 !< Default integer value + integer, parameter :: fourier_rings = 5 !< Fourier filter ring limit + integer, parameter :: num_fluids_max = 10 !< Maximum number of fluids in the simulation + integer, parameter :: num_probes_max = 10 !< Maximum number of flow probes in the simulation integer, parameter :: num_patches_max = 10 - integer, parameter :: pathlen_max = 400 - integer, parameter :: nnode = 4 !< Number of QBMM nodes + integer, parameter :: pathlen_max = 400 + integer, parameter :: nnode = 4 !< Number of QBMM nodes end module m_constants diff --git a/src/common/m_delay_file_access.f90 b/src/common/m_delay_file_access.f90 index 079297cac..7883f3dea 100644 --- a/src/common/m_delay_file_access.f90 +++ b/src/common/m_delay_file_access.f90 @@ -1,37 +1,37 @@ module m_delay_file_access implicit none private - + public :: & - DelayFileAccess - - integer, private, parameter :: & + DelayFileAccess + + integer, private, parameter :: & N_PROCESSES_FILE_ACCESS = 128, & - FILE_ACCESS_DELAY_UNIT = 10000 - - contains - - subroutine DelayFileAccess ( ProcessRank ) - - integer, intent ( in ) :: & - ProcessRank - - integer :: & - iDelay, & - nFileAccessDelayIterations - real(kind(0d0)) :: & - Number, & - Dummy - - nFileAccessDelayIterations & - = ( ProcessRank / N_PROCESSES_FILE_ACCESS ) * FILE_ACCESS_DELAY_UNIT - - do iDelay = 1, nFileAccessDelayIterations - !-- wait my turn - call random_number ( Number ) - Dummy = Number * Number - end do - + FILE_ACCESS_DELAY_UNIT = 10000 + +contains + + subroutine DelayFileAccess(ProcessRank) + + integer, intent(in) :: & + ProcessRank + + integer :: & + iDelay, & + nFileAccessDelayIterations + real(kind(0d0)) :: & + Number, & + Dummy + + nFileAccessDelayIterations & + = (ProcessRank/N_PROCESSES_FILE_ACCESS)*FILE_ACCESS_DELAY_UNIT + + do iDelay = 1, nFileAccessDelayIterations + !-- wait my turn + call random_number(Number) + Dummy = Number*Number + end do + end subroutine DelayFileAccess -end module m_delay_file_access \ No newline at end of file +end module m_delay_file_access diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 5d44d12c9..29989b860 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -9,7 +9,7 @@ module m_derived_types use m_constants !< Constants - + implicit none !> Derived type adding the field position (fp) as an attribute @@ -96,7 +96,7 @@ module m_derived_types end type t_bbox type :: t_model - integer :: ntrs ! Number of triangles + integer :: ntrs ! Number of triangles type(t_triangle), allocatable :: trs(:) ! Triangles end type t_model @@ -156,7 +156,6 @@ module m_derived_types real(kind(0d0)) :: qv !< real(kind(0d0)) :: qvp !< - !! Primitive variables associated with the patch. In order, these include !! the partial densities, density, velocity, pressure, volume fractions, !! specific heat ratio function and the liquid stiffness function. @@ -181,9 +180,9 @@ module m_derived_types real(kind(0d0)) :: gamma !< Sp. heat ratio real(kind(0d0)) :: pi_inf !< Liquid stiffness real(kind(0d0)), dimension(2) :: Re !< Reynolds number - REAL(KIND(0d0)) :: cv !< heat capacity - REAL(KIND(0d0)) :: qv !< reference energy per unit mass for SGEOS, q (see Le Metayer (2004)) - REAL(KIND(0d0)) :: qvp !< reference entropy per unit mass for SGEOS, q' (see Le Metayer (2004)) + real(kind(0d0)) :: cv !< heat capacity + real(kind(0d0)) :: qv !< reference energy per unit mass for SGEOS, q (see Le Metayer (2004)) + real(kind(0d0)) :: qvp !< reference entropy per unit mass for SGEOS, q' (see Le Metayer (2004)) real(kind(0d0)) :: mul0 !< Bubble viscosity real(kind(0d0)) :: ss !< Bubble surface tension real(kind(0d0)) :: pv !< Bubble vapour pressure diff --git a/src/common/m_eigen_solver.f90 b/src/common/m_eigen_solver.f90 index 03a6d88f7..8a8ca8547 100644 --- a/src/common/m_eigen_solver.f90 +++ b/src/common/m_eigen_solver.f90 @@ -10,11 +10,11 @@ module m_eigen_solver implicit none - private; public :: cg,cbal,corth,comqr2,csroot,cdiv,pythag - + private; public :: cg, cbal, corth, comqr2, csroot, cdiv, pythag + contains - subroutine cg(nm,nl,ar,ai,wr,wi,zr,zi,fv1,fv2,fv3,ierr) + subroutine cg(nm, nl, ar, ai, wr, wi, zr, zi, fv1, fv2, fv3, ierr) ! this subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (eispack) ! to find the eigenvalues and eigenvectors (if desired) @@ -50,25 +50,25 @@ subroutine cg(nm,nl,ar,ai,wr,wi,zr,zi,fv1,fv2,fv3,ierr) ! ! this version dated august 1983. ! -! ------------------------------------------------------------------ - integer nm,nl,is1,is2,ierr - real(kind(0d0)), dimension(nm,nl) :: ar,ai,zr,zi - real(kind(0d0)), dimension(nl) :: wr,wi,fv1,fv2,fv3 +! ------------------------------------------------------------------ + integer nm, nl, is1, is2, ierr + real(kind(0d0)), dimension(nm, nl) :: ar, ai, zr, zi + real(kind(0d0)), dimension(nl) :: wr, wi, fv1, fv2, fv3 - if (nl .le. nm) go to 10 + if (nl <= nm) go to 10 ierr = 10*nl go to 50 -10 call cbal(nm,nl,ar,ai,is1,is2,fv1) - call corth(nm,nl,is1,is2,ar,ai,fv2,fv3) - call comqr2(nm,nl,is1,is2,fv2,fv3,ar,ai,wr,wi,zr,zi,ierr) - if (ierr .ne. 0) go to 50 - call cbabk2(nm,nl,is1,is2,fv1,nl,zr,zi) +10 call cbal(nm, nl, ar, ai, is1, is2, fv1) + call corth(nm, nl, is1, is2, ar, ai, fv2, fv3) + call comqr2(nm, nl, is1, is2, fv2, fv3, ar, ai, wr, wi, zr, zi, ierr) + if (ierr /= 0) go to 50 + call cbabk2(nm, nl, is1, is2, fv1, nl, zr, zi) -50 return +50 return end subroutine cg - subroutine cbal(nm,nl,ar,ai,low,igh,scale) + subroutine cbal(nm, nl, ar, ai, low, igh, scale) ! this subroutine is a translation of the algol procedure ! cbalance, which is a complex version of balance, ! num. math. 13, 293-304(1969) by parlett and reinsch. @@ -125,59 +125,59 @@ subroutine cbal(nm,nl,ar,ai,low,igh,scale) ! this version dated august 1983. ! ! ------------------------------------------------------------------ - integer i,j,k,l,ml,nl,jj,nm,igh,low,iexc - real(kind(0d0)), dimension(nm,nl) :: ar,ai + integer i, j, k, l, ml, nl, jj, nm, igh, low, iexc + real(kind(0d0)), dimension(nm, nl) :: ar, ai real(kind(0d0)), dimension(nl) :: scale - real(kind(0d0)) :: c,f,g,r,s,b2,radix + real(kind(0d0)) :: c, f, g, r, s, b2, radix logical noconv radix = 16.0d0 - b2 = radix * radix + b2 = radix*radix k = 1 l = nl go to 100 ! .......... in-line procedure for row and ! column exchange .......... 20 scale(ml) = j - if (j .eq. ml) go to 50 + if (j == ml) go to 50 do 30 i = 1, l - f = ar(i,j) - ar(i,j) = ar(i,ml) - ar(i,ml) = f - f = ai(i,j) - ai(i,j) = ai(i,ml) - ai(i,ml) = f -30 continue + f = ar(i, j) + ar(i, j) = ar(i, ml) + ar(i, ml) = f + f = ai(i, j) + ai(i, j) = ai(i, ml) + ai(i, ml) = f +30 end do do 40 i = k, nl - f = ar(j,i) - ar(j,i) = ar(ml,i) - ar(ml,i) = f - f = ai(j,i) - ai(j,i) = ai(ml,i) - ai(ml,i) = f -40 continue - -50 go to (80,130), iexc + f = ar(j, i) + ar(j, i) = ar(ml, i) + ar(ml, i) = f + f = ai(j, i) + ai(j, i) = ai(ml, i) + ai(ml, i) = f +40 end do + +50 go to(80, 130), iexc ! .......... search for rows isolating an eigenvalue ! and push them down .......... -80 if (l .eq. 1) go to 280 - l = l - 1 +80 if (l == 1) go to 280 + l = l - 1 ! .......... for j=l step -1 until 1 do -- .......... 100 do 120 jj = 1, l j = l + 1 - jj - do 110 i = 1, l - if (i .eq. j) go to 110 - if (ar(j,i) .ne. 0.0d0 .or. ai(j,i) .ne. 0.0d0) go to 120 -110 continue + do 110 i = 1, l + if (i == j) go to 110 + if (ar(j, i) /= 0.0d0 .or. ai(j, i) /= 0.0d0) go to 120 +110 end do - ml = l - iexc = 1 - go to 20 -120 continue + ml = l + iexc = 1 + go to 20 +120 end do go to 140 ! .......... search for columns isolating an eigenvalue @@ -186,19 +186,19 @@ subroutine cbal(nm,nl,ar,ai,low,igh,scale) 140 do 170 j = k, l - do 150 i = k, l - if (i .eq. j) go to 150 - if (ar(i,j) .ne. 0.0d0 .or. ai(i,j) .ne. 0.0d0) go to 170 -150 continue + do 150 i = k, l + if (i == j) go to 150 + if (ar(i, j) /= 0.0d0 .or. ai(i, j) /= 0.0d0) go to 170 +150 end do - ml = k - iexc = 2 - go to 20 -170 continue + ml = k + iexc = 2 + go to 20 +170 end do ! .......... now balance the submatrix in rows k to l .......... do 180 i = k, l - scale(i) = 1.0d0 -180 continue + scale(i) = 1.0d0 +180 end do ! .......... iterative loop for norm reduction .......... 190 noconv = .false. @@ -206,51 +206,51 @@ subroutine cbal(nm,nl,ar,ai,low,igh,scale) c = 0.0d0 r = 0.0d0 - do 200 j = k, l - if (j .eq. i) go to 200 - c = c + dabs(ar(j,i)) + dabs(ai(j,i)) - r = r + dabs(ar(i,j)) + dabs(ai(i,j)) -200 continue + do 200 j = k, l + if (j == i) go to 200 + c = c + dabs(ar(j, i)) + dabs(ai(j, i)) + r = r + dabs(ar(i, j)) + dabs(ai(i, j)) +200 end do ! .......... guard against zero c or r due to underflow .......... - if (c .eq. 0.0d0 .or. r .eq. 0.0d0) go to 270 - g = r / radix - f = 1.0d0 - s = c + r -210 if (c .ge. g) go to 220 - f = f * radix - c = c * b2 - go to 210 -220 g = r * radix -230 if (c .lt. g) go to 240 - f = f / radix - c = c / b2 - go to 230 + if (c == 0.0d0 .or. r == 0.0d0) go to 270 + g = r/radix + f = 1.0d0 + s = c + r +210 if (c >= g) go to 220 + f = f*radix + c = c*b2 + go to 210 +220 g = r*radix +230 if (c < g) go to 240 + f = f/radix + c = c/b2 + go to 230 ! .......... now balance .......... -240 if ((c + r) / f .ge. 0.95d0 * s) go to 270 - g = 1.0d0 / f - scale(i) = scale(i) * f - noconv = .true. +240 if ((c + r)/f >= 0.95d0*s) go to 270 + g = 1.0d0/f + scale(i) = scale(i)*f + noconv = .true. - do 250 j = k, nl - ar(i,j) = ar(i,j) * g - ai(i,j) = ai(i,j) * g -250 continue + do 250 j = k, nl + ar(i, j) = ar(i, j)*g + ai(i, j) = ai(i, j)*g +250 end do - do 260 j = 1, l - ar(j,i) = ar(j,i) * f - ai(j,i) = ai(j,i) * f -260 continue + do 260 j = 1, l + ar(j, i) = ar(j, i)*f + ai(j, i) = ai(j, i)*f +260 end do -270 continue +270 end do if (noconv) go to 190 280 low = k igh = l - return + return end subroutine cbal - - subroutine corth(nm,nl,low,igh,ar,ai,ortr,orti) + + subroutine corth(nm, nl, low, igh, ar, ai, ortr, orti) ! this subroutine is a translation of a complex analogue of ! the algol procedure orthes, num. math. 12, 349-368(1968) ! by martin and wilkinson. @@ -295,17 +295,17 @@ subroutine corth(nm,nl,low,igh,ar,ai,ortr,orti) ! this version dated august 1983. ! ! ------------------------------------------------------------------ - integer i,j,ml,nl,ii,jj,la,mp,nm,igh,kp1,low - real(kind(0d0)),dimension(nm,nl) :: ar,ai - real(kind(0d0)),dimension(igh) :: ortr,orti - real(kind(0d0)) :: f,g,h,fi,fr,scale,c + integer i, j, ml, nl, ii, jj, la, mp, nm, igh, kp1, low + real(kind(0d0)), dimension(nm, nl) :: ar, ai + real(kind(0d0)), dimension(igh) :: ortr, orti + real(kind(0d0)) :: f, g, h, fi, fr, scale, c integer mll mll = 6 - + la = igh - 1 kp1 = low + 1 - if (la .lt. kp1) go to 200 + if (la < kp1) go to 200 do 180 ml = kp1, la h = 0.0d0 @@ -313,81 +313,81 @@ subroutine corth(nm,nl,low,igh,ar,ai,ortr,orti) orti(ml) = 0.0d0 scale = 0.0d0 ! .......... scale column (algol tol then not needed) .......... - do 90 i = ml, igh - scale = scale + dabs(ar(i,ml-1)) + dabs(ai(i,ml-1)) -90 continue - if (scale .eq. 0d0) go to 180 - mp = ml + igh + do 90 i = ml, igh + scale = scale + dabs(ar(i, ml - 1)) + dabs(ai(i, ml - 1)) +90 end do + if (scale == 0d0) go to 180 + mp = ml + igh ! .......... for i=igh step -1 until ml do -- .......... - do 100 ii = ml, igh - i = mp - ii - ortr(i) = ar(i,ml-1) / scale - orti(i) = ai(i,ml-1) / scale - h = h + ortr(i) * ortr(i) + orti(i) * orti(i) -100 continue -! - g = dsqrt(h) - call pythag(ortr(ml),orti(ml),f) - if (f .eq. 0d0) go to 103 - h = h + f * g - g = g / f - ortr(ml) = (1.0d0 + g) * ortr(ml) - orti(ml) = (1.0d0 + g) * orti(ml) - go to 105 - -103 ortr(ml) = g - ar(ml,ml-1) = scale + do 100 ii = ml, igh + i = mp - ii + ortr(i) = ar(i, ml - 1)/scale + orti(i) = ai(i, ml - 1)/scale + h = h + ortr(i)*ortr(i) + orti(i)*orti(i) +100 end do +! + g = dsqrt(h) + call pythag(ortr(ml), orti(ml), f) + if (f == 0d0) go to 103 + h = h + f*g + g = g/f + ortr(ml) = (1.0d0 + g)*ortr(ml) + orti(ml) = (1.0d0 + g)*orti(ml) + go to 105 + +103 ortr(ml) = g + ar(ml, ml - 1) = scale ! .......... form (i-(u*ut)/h) * a .......... -105 do 130 j = ml, nl - fr = 0.0d0 - fi = 0.0d0 +105 do 130 j = ml, nl + fr = 0.0d0 + fi = 0.0d0 ! .......... for i=igh step -1 until ml do -- .......... - do 110 ii = ml, igh - i = mp - ii - fr = fr + ortr(i) * ar(i,j) + orti(i) * ai(i,j) - fi = fi + ortr(i) * ai(i,j) - orti(i) * ar(i,j) -110 continue + do 110 ii = ml, igh + i = mp - ii + fr = fr + ortr(i)*ar(i, j) + orti(i)*ai(i, j) + fi = fi + ortr(i)*ai(i, j) - orti(i)*ar(i, j) +110 end do ! - fr = fr / h - fi = fi / h + fr = fr/h + fi = fi/h ! - do 120 i = ml, igh - ar(i,j) = ar(i,j) - fr * ortr(i) + fi * orti(i) - ai(i,j) = ai(i,j) - fr * orti(i) - fi * ortr(i) -120 continue + do 120 i = ml, igh + ar(i, j) = ar(i, j) - fr*ortr(i) + fi*orti(i) + ai(i, j) = ai(i, j) - fr*orti(i) - fi*ortr(i) +120 end do ! -130 continue +130 end do ! .......... form (i-(u*ut)/h)*a*(i-(u*ut)/h) .......... - do 160 i = 1, igh - fr = 0.0d0 - fi = 0.0d0 + do 160 i = 1, igh + fr = 0.0d0 + fi = 0.0d0 ! .......... for j=igh step -1 until ml do -- .......... - do 140 jj = ml, igh - j = mp - jj - fr = fr + ortr(j) * ar(i,j) - orti(j) * ai(i,j) - fi = fi + ortr(j) * ai(i,j) + orti(j) * ar(i,j) -140 continue + do 140 jj = ml, igh + j = mp - jj + fr = fr + ortr(j)*ar(i, j) - orti(j)*ai(i, j) + fi = fi + ortr(j)*ai(i, j) + orti(j)*ar(i, j) +140 end do ! - fr = fr / h - fi = fi / h + fr = fr/h + fi = fi/h ! - do 150 j = ml, igh - ar(i,j) = ar(i,j) - fr * ortr(j) - fi * orti(j) - ai(i,j) = ai(i,j) + fr * orti(j) - fi * ortr(j) -150 continue + do 150 j = ml, igh + ar(i, j) = ar(i, j) - fr*ortr(j) - fi*orti(j) + ai(i, j) = ai(i, j) + fr*orti(j) - fi*ortr(j) +150 end do ! -160 continue +160 end do ! - ortr(ml) = scale * ortr(ml) - orti(ml) = scale * orti(ml) - ar(ml,ml-1) = -g * ar(ml,ml-1) - ai(ml,ml-1) = -g * ai(ml,ml-1) -180 continue + ortr(ml) = scale*ortr(ml) + orti(ml) = scale*orti(ml) + ar(ml, ml - 1) = -g*ar(ml, ml - 1) + ai(ml, ml - 1) = -g*ai(ml, ml - 1) +180 end do ! -200 return +200 return end subroutine corth - - subroutine comqr2(nm,nl,low,igh,ortr,orti,hr,hi,wr,wi,zr,zi,ierr) + + subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) ! MESHED overflow control WITH vectors of isolated roots (10/19/89 BSG) ! MESHED overflow control WITH triangular multiply (10/30/89 BSG) ! @@ -460,147 +460,147 @@ subroutine comqr2(nm,nl,low,igh,ortr,orti,hr,hi,wr,wi,zr,zi,ierr) ! this version dated october 1989. ! ! ------------------------------------------------------------------ - integer i,j,k,l,ml,nl,en,ii,jj,ll,nm,nn,igh,ip1,& - itn,its,low,lp1,enm1,iend,ierr - real(kind(0d0)),dimension(nm,nl) :: hr,hi,zr,zi - real(kind(0d0)),dimension(nl) :: wr,wi - real(kind(0d0)),dimension(igh) :: ortr,orti - real(kind(0d0)) :: si,sr,ti,tr,xi,xr,yi,yr,zzi,zzr,& - norm,tst1,tst2,c,d + integer i, j, k, l, ml, nl, en, ii, jj, ll, nm, nn, igh, ip1, & + itn, its, low, lp1, enm1, iend, ierr + real(kind(0d0)), dimension(nm, nl) :: hr, hi, zr, zi + real(kind(0d0)), dimension(nl) :: wr, wi + real(kind(0d0)), dimension(igh) :: ortr, orti + real(kind(0d0)) :: si, sr, ti, tr, xi, xr, yi, yr, zzi, zzr, & + norm, tst1, tst2, c, d ! ierr = 0 ! .......... initialize eigenvector matrix .......... do 101 j = 1, nl ! - do 100 i = 1, nl - zr(i,j) = 0.0d0 - zi(i,j) = 0.0d0 -100 continue - zr(j,j) = 1.0d0 -101 continue + do 100 i = 1, nl + zr(i, j) = 0.0d0 + zi(i, j) = 0.0d0 +100 end do + zr(j, j) = 1.0d0 +101 end do ! .......... form the matrix of accumulated transformations ! from the information left by corth .......... iend = igh - low - 1 - if (iend .lt. 0) go to 180 - if (iend .eq. 0) go to 150 - if (iend .gt. 0) go to 105 + if (iend < 0) go to 180 + if (iend == 0) go to 150 + if (iend > 0) go to 105 ! .......... for i=igh-1 step -1 until low+1 do -- .......... 105 do 140 ii = 1, iend - i = igh - ii - if (dabs(ortr(i)) .eq. 0d0 .and. dabs(orti(i)) .eq. 0d0) go to 140 - if (dabs(hr(i,i-1)) .eq. 0d0 .and. dabs(hi(i,i-1)) .eq. 0d0) go to 140 + i = igh - ii + if (dabs(ortr(i)) == 0d0 .and. dabs(orti(i)) == 0d0) go to 140 + if (dabs(hr(i, i - 1)) == 0d0 .and. dabs(hi(i, i - 1)) == 0d0) go to 140 ! .......... norm below is negative of h formed in corth .......... - norm = hr(i,i-1) * ortr(i) + hi(i,i-1) * orti(i) - ip1 = i + 1 + norm = hr(i, i - 1)*ortr(i) + hi(i, i - 1)*orti(i) + ip1 = i + 1 - do 110 k = ip1, igh - ortr(k) = hr(k,i-1) - orti(k) = hi(k,i-1) -110 continue + do 110 k = ip1, igh + ortr(k) = hr(k, i - 1) + orti(k) = hi(k, i - 1) +110 end do ! - do 130 j = i, igh - sr = 0.0d0 - si = 0.0d0 + do 130 j = i, igh + sr = 0.0d0 + si = 0.0d0 ! - do 115 k = i, igh - sr = sr + ortr(k) * zr(k,j) + orti(k) * zi(k,j) - si = si + ortr(k) * zi(k,j) - orti(k) * zr(k,j) -115 continue + do 115 k = i, igh + sr = sr + ortr(k)*zr(k, j) + orti(k)*zi(k, j) + si = si + ortr(k)*zi(k, j) - orti(k)*zr(k, j) +115 end do ! - sr = sr / norm - si = si / norm + sr = sr/norm + si = si/norm ! - do 120 k = i, igh - zr(k,j) = zr(k,j) + sr * ortr(k) - si * orti(k) - zi(k,j) = zi(k,j) + sr * orti(k) + si * ortr(k) -120 continue + do 120 k = i, igh + zr(k, j) = zr(k, j) + sr*ortr(k) - si*orti(k) + zi(k, j) = zi(k, j) + sr*orti(k) + si*ortr(k) +120 end do ! -130 continue +130 end do ! -140 continue +140 end do ! .......... create real subdiagonal elements .......... 150 l = low + 1 ! do 170 i = l, igh - ll = min0(i+1,igh) - if (dabs(hi(i,i-1)) .eq. 0d0) go to 170 - call pythag(hr(i,i-1),hi(i,i-1),norm) - yr = hr(i,i-1) / norm - yi = hi(i,i-1) / norm - hr(i,i-1) = norm - hi(i,i-1) = 0.0d0 -! - do 155 j = i, nl - si = yr * hi(i,j) - yi * hr(i,j) - hr(i,j) = yr * hr(i,j) + yi * hi(i,j) - hi(i,j) = si -155 continue -! - do 160 j = 1, ll - si = yr * hi(j,i) + yi * hr(j,i) - hr(j,i) = yr * hr(j,i) - yi * hi(j,i) - hi(j,i) = si -160 continue -! - do 165 j = low, igh - si = yr * zi(j,i) + yi * zr(j,i) - zr(j,i) = yr * zr(j,i) - yi * zi(j,i) - zi(j,i) = si -165 continue - -170 continue + ll = min0(i + 1, igh) + if (dabs(hi(i, i - 1)) == 0d0) go to 170 + call pythag(hr(i, i - 1), hi(i, i - 1), norm) + yr = hr(i, i - 1)/norm + yi = hi(i, i - 1)/norm + hr(i, i - 1) = norm + hi(i, i - 1) = 0.0d0 +! + do 155 j = i, nl + si = yr*hi(i, j) - yi*hr(i, j) + hr(i, j) = yr*hr(i, j) + yi*hi(i, j) + hi(i, j) = si +155 end do +! + do 160 j = 1, ll + si = yr*hi(j, i) + yi*hr(j, i) + hr(j, i) = yr*hr(j, i) - yi*hi(j, i) + hi(j, i) = si +160 end do +! + do 165 j = low, igh + si = yr*zi(j, i) + yi*zr(j, i) + zr(j, i) = yr*zr(j, i) - yi*zi(j, i) + zi(j, i) = si +165 end do + +170 end do ! .......... store roots isolated by cbal .......... 180 do 200 i = 1, nl - if (i .ge. low .and. i .le. igh) go to 200 - wr(i) = hr(i,i) - wi(i) = hi(i,i) -200 continue + if (i >= low .and. i <= igh) go to 200 + wr(i) = hr(i, i) + wi(i) = hi(i, i) +200 end do ! en = igh tr = 0.0d0 ti = 0.0d0 itn = 30*nl ! .......... search for next eigenvalue .......... -220 if (en .lt. low) go to 680 +220 if (en < low) go to 680 its = 0 enm1 = en - 1 ! .......... look for single small sub-diagonal element ! for l=en step -1 until low do -- .......... 240 do 260 ll = low, en - l = en + low - ll - if (l .eq. low) go to 300 - tst1 = dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1)) & - + dabs(hr(l,l)) + dabs(hi(l,l)) - tst2 = tst1 + dabs(hr(l,l-1)) - if (tst2 .eq. tst1) go to 300 -260 continue + l = en + low - ll + if (l == low) go to 300 + tst1 = dabs(hr(l - 1, l - 1)) + dabs(hi(l - 1, l - 1)) & + + dabs(hr(l, l)) + dabs(hi(l, l)) + tst2 = tst1 + dabs(hr(l, l - 1)) + if (tst2 == tst1) go to 300 +260 end do ! .......... form shift .......... -300 if (l .eq. en) go to 660 - if (itn .eq. 0) go to 1000 - if (its .eq. 10 .or. its .eq. 20) go to 320 - sr = hr(en,en) - si = hi(en,en) - xr = hr(enm1,en) * hr(en,enm1) - xi = hi(enm1,en) * hr(en,enm1) - if (xr .eq. 0.0d0 .and. xi .eq. 0.0d0) go to 340 - yr = (hr(enm1,enm1) - sr) / 2.0d0 - yi = (hi(enm1,enm1) - si) / 2.0d0 - call csroot(yr**2-yi**2+xr,2.0d0*yr*yi+xi,zzr,zzi) - if (yr * zzr + yi * zzi .ge. 0.0d0) go to 310 +300 if (l == en) go to 660 + if (itn == 0) go to 1000 + if (its == 10 .or. its == 20) go to 320 + sr = hr(en, en) + si = hi(en, en) + xr = hr(enm1, en)*hr(en, enm1) + xi = hi(enm1, en)*hr(en, enm1) + if (xr == 0.0d0 .and. xi == 0.0d0) go to 340 + yr = (hr(enm1, enm1) - sr)/2.0d0 + yi = (hi(enm1, enm1) - si)/2.0d0 + call csroot(yr**2 - yi**2 + xr, 2.0d0*yr*yi + xi, zzr, zzi) + if (yr*zzr + yi*zzi >= 0.0d0) go to 310 zzr = -zzr zzi = -zzi -310 call cdiv(xr,xi,yr+zzr,yi+zzi,xr,xi) +310 call cdiv(xr, xi, yr + zzr, yi + zzi, xr, xi) sr = sr - xr si = si - xi go to 340 ! .......... form exceptional shift .......... -320 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2)) +320 sr = dabs(hr(en, enm1)) + dabs(hr(enm1, en - 2)) si = 0.0d0 ! 340 do 360 i = low, en - hr(i,i) = hr(i,i) - sr - hi(i,i) = hi(i,i) - si -360 continue + hr(i, i) = hr(i, i) - sr + hi(i, i) = hi(i, i) - si +360 end do ! tr = tr + sr ti = ti + si @@ -610,100 +610,100 @@ subroutine comqr2(nm,nl,low,igh,ortr,orti,hr,hi,wr,wi,zr,zi,ierr) lp1 = l + 1 ! do 500 i = lp1, en - sr = hr(i,i-1) - hr(i,i-1) = 0.0d0 - call pythag(hr(i-1,i-1),hi(i-1,i-1),c) - call pythag(c,sr,norm) - xr = hr(i-1,i-1) / norm - wr(i-1) = xr - xi = hi(i-1,i-1) / norm - wi(i-1) = xi - hr(i-1,i-1) = norm - hi(i-1,i-1) = 0.0d0 - hi(i,i-1) = sr / norm -! - do 490 j = i, nl - yr = hr(i-1,j) - yi = hi(i-1,j) - zzr = hr(i,j) - zzi = hi(i,j) - hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr - hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi - hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr - hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi -490 continue -! -500 continue -! - si = hi(en,en) - if (dabs(si) .eq. 0d0) go to 540 - call pythag(hr(en,en),si,norm) - sr = hr(en,en) / norm - si = si / norm - hr(en,en) = norm - hi(en,en) = 0.0d0 - if (en .eq. nl) go to 540 + sr = hr(i, i - 1) + hr(i, i - 1) = 0.0d0 + call pythag(hr(i - 1, i - 1), hi(i - 1, i - 1), c) + call pythag(c, sr, norm) + xr = hr(i - 1, i - 1)/norm + wr(i - 1) = xr + xi = hi(i - 1, i - 1)/norm + wi(i - 1) = xi + hr(i - 1, i - 1) = norm + hi(i - 1, i - 1) = 0.0d0 + hi(i, i - 1) = sr/norm +! + do 490 j = i, nl + yr = hr(i - 1, j) + yi = hi(i - 1, j) + zzr = hr(i, j) + zzi = hi(i, j) + hr(i - 1, j) = xr*yr + xi*yi + hi(i, i - 1)*zzr + hi(i - 1, j) = xr*yi - xi*yr + hi(i, i - 1)*zzi + hr(i, j) = xr*zzr - xi*zzi - hi(i, i - 1)*yr + hi(i, j) = xr*zzi + xi*zzr - hi(i, i - 1)*yi +490 end do +! +500 end do +! + si = hi(en, en) + if (dabs(si) == 0d0) go to 540 + call pythag(hr(en, en), si, norm) + sr = hr(en, en)/norm + si = si/norm + hr(en, en) = norm + hi(en, en) = 0.0d0 + if (en == nl) go to 540 ip1 = en + 1 ! do 520 j = ip1, nl - yr = hr(en,j) - yi = hi(en,j) - hr(en,j) = sr * yr + si * yi - hi(en,j) = sr * yi - si * yr -520 continue + yr = hr(en, j) + yi = hi(en, j) + hr(en, j) = sr*yr + si*yi + hi(en, j) = sr*yi - si*yr +520 end do ! .......... inverse operation (columns) .......... 540 do 600 j = lp1, en - xr = wr(j-1) - xi = wi(j-1) -! - do 580 i = 1, j - yr = hr(i,j-1) - yi = 0.0d0 - zzr = hr(i,j) - zzi = hi(i,j) - if (i .eq. j) go to 560 - yi = hi(i,j-1) - hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi -560 hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr - hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr - hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi -580 continue -! - do 590 i = low, igh - yr = zr(i,j-1) - yi = zi(i,j-1) - zzr = zr(i,j) - zzi = zi(i,j) - zr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr - zi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi - zr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr - zi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi -590 continue - -600 continue -! - if (dabs(si) .eq. 0d0) go to 240 + xr = wr(j - 1) + xi = wi(j - 1) +! + do 580 i = 1, j + yr = hr(i, j - 1) + yi = 0.0d0 + zzr = hr(i, j) + zzi = hi(i, j) + if (i == j) go to 560 + yi = hi(i, j - 1) + hi(i, j - 1) = xr*yi + xi*yr + hi(j, j - 1)*zzi +560 hr(i, j - 1) = xr*yr - xi*yi + hi(j, j - 1)*zzr + hr(i, j) = xr*zzr + xi*zzi - hi(j, j - 1)*yr + hi(i, j) = xr*zzi - xi*zzr - hi(j, j - 1)*yi +580 end do +! + do 590 i = low, igh + yr = zr(i, j - 1) + yi = zi(i, j - 1) + zzr = zr(i, j) + zzi = zi(i, j) + zr(i, j - 1) = xr*yr - xi*yi + hi(j, j - 1)*zzr + zi(i, j - 1) = xr*yi + xi*yr + hi(j, j - 1)*zzi + zr(i, j) = xr*zzr + xi*zzi - hi(j, j - 1)*yr + zi(i, j) = xr*zzi - xi*zzr - hi(j, j - 1)*yi +590 end do + +600 end do +! + if (dabs(si) == 0d0) go to 240 ! do 630 i = 1, en - yr = hr(i,en) - yi = hi(i,en) - hr(i,en) = sr * yr - si * yi - hi(i,en) = sr * yi + si * yr -630 continue + yr = hr(i, en) + yi = hi(i, en) + hr(i, en) = sr*yr - si*yi + hi(i, en) = sr*yi + si*yr +630 end do ! do 640 i = low, igh - yr = zr(i,en) - yi = zi(i,en) - zr(i,en) = sr * yr - si * yi - zi(i,en) = sr * yi + si * yr -640 continue + yr = zr(i, en) + yi = zi(i, en) + zr(i, en) = sr*yr - si*yi + zi(i, en) = sr*yi + si*yr +640 end do ! go to 240 ! .......... a root found .......... -660 hr(en,en) = hr(en,en) + tr - wr(en) = hr(en,en) - hi(en,en) = hi(en,en) + ti - wi(en) = hi(en,en) +660 hr(en, en) = hr(en, en) + tr + wr(en) = hr(en, en) + hi(en, en) = hi(en, en) + ti + wi(en) = hi(en, en) en = enm1 go to 220 ! .......... all roots found. backsubstitute to find @@ -711,87 +711,87 @@ subroutine comqr2(nm,nl,low,igh,ortr,orti,hr,hi,wr,wi,zr,zi,ierr) 680 norm = 0.0d0 ! do i = 1, nl - do j = i, nl - tr = dabs(hr(i,j)) + dabs(hi(i,j)) - if (tr .gt. norm) norm = tr - end do + do j = i, nl + tr = dabs(hr(i, j)) + dabs(hi(i, j)) + if (tr > norm) norm = tr + end do end do ! - if (nl .eq. 1 .or. norm .eq. 0d0) go to 1001 + if (nl == 1 .or. norm == 0d0) go to 1001 ! .......... for en=nl step -1 until 2 do -- .......... do 800 nn = 2, nl - en = nl + 2 - nn - xr = wr(en) - xi = wi(en) - hr(en,en) = 1.0d0 - hi(en,en) = 0.0d0 - enm1 = en - 1 + en = nl + 2 - nn + xr = wr(en) + xi = wi(en) + hr(en, en) = 1.0d0 + hi(en, en) = 0.0d0 + enm1 = en - 1 ! .......... for i=en-1 step -1 until 1 do -- .......... - do 780 ii = 1, enm1 - i = en - ii - zzr = 0.0d0 - zzi = 0.0d0 - ip1 = i + 1 - - do 740 j = ip1, en - zzr = zzr + hr(i,j) * hr(j,en) - hi(i,j) * hi(j,en) - zzi = zzi + hr(i,j) * hi(j,en) + hi(i,j) * hr(j,en) -740 continue -! - yr = xr - wr(i) - yi = xi - wi(i) - if (yr .ne. 0.0d0 .or. yi .ne. 0.0d0) go to 765 - tst1 = norm - yr = tst1 -760 yr = 0.01d0 * yr - tst2 = norm + yr - if (tst2 .gt. tst1) go to 760 -765 continue - call cdiv(zzr,zzi,yr,yi,hr(i,en),hi(i,en)) + do 780 ii = 1, enm1 + i = en - ii + zzr = 0.0d0 + zzi = 0.0d0 + ip1 = i + 1 + + do 740 j = ip1, en + zzr = zzr + hr(i, j)*hr(j, en) - hi(i, j)*hi(j, en) + zzi = zzi + hr(i, j)*hi(j, en) + hi(i, j)*hr(j, en) +740 end do +! + yr = xr - wr(i) + yi = xi - wi(i) + if (yr /= 0.0d0 .or. yi /= 0.0d0) go to 765 + tst1 = norm + yr = tst1 +760 yr = 0.01d0*yr + tst2 = norm + yr + if (tst2 > tst1) go to 760 +765 continue + call cdiv(zzr, zzi, yr, yi, hr(i, en), hi(i, en)) ! .......... overflow control .......... - tr = dabs(hr(i,en)) + dabs(hi(i,en)) - if (tr .eq. 0.0d0) go to 780 - tst1 = tr - tst2 = tst1 + 1.0d0/tst1 - if (tst2 .gt. tst1) go to 780 - do 770 j = i, en - hr(j,en) = hr(j,en)/tr - hi(j,en) = hi(j,en)/tr -770 continue -! -780 continue -! -800 continue + tr = dabs(hr(i, en)) + dabs(hi(i, en)) + if (tr == 0.0d0) go to 780 + tst1 = tr + tst2 = tst1 + 1.0d0/tst1 + if (tst2 > tst1) go to 780 + do 770 j = i, en + hr(j, en) = hr(j, en)/tr + hi(j, en) = hi(j, en)/tr +770 end do +! +780 end do +! +800 end do ! .......... end backsubstitution .......... ! .......... vectors of isolated roots .......... - do 840 i = 1, nl - if (i .ge. low .and. i .le. igh) go to 840 + do 840 i = 1, nl + if (i >= low .and. i <= igh) go to 840 ! - do 820 j = I, nl - zr(i,j) = hr(i,j) - zi(i,j) = hi(i,j) -820 continue + do 820 j = I, nl + zr(i, j) = hr(i, j) + zi(i, j) = hi(i, j) +820 end do ! -840 continue +840 end do ! .......... multiply by transformation matrix to give ! vectors of original full matrix. ! for j=nl step -1 until low do -- .......... do jj = low, nl - j = nl + low - jj - ml = min0(j,igh) + j = nl + low - jj + ml = min0(j, igh) ! - do i = low, igh - zzr = 0.0d0 - zzi = 0.0d0 + do i = low, igh + zzr = 0.0d0 + zzi = 0.0d0 ! - do 860 k = low, ml - zzr = zzr + zr(i,k) * hr(k,j) - zi(i,k) * hi(k,j) - zzi = zzi + zr(i,k) * hi(k,j) + zi(i,k) * hr(k,j) -860 continue + do 860 k = low, ml + zzr = zzr + zr(i, k)*hr(k, j) - zi(i, k)*hi(k, j) + zzi = zzi + zr(i, k)*hi(k, j) + zi(i, k)*hr(k, j) +860 end do ! - zr(i,j) = zzr - zi(i,j) = zzi - end do + zr(i, j) = zzr + zi(i, j) = zzi + end do end do ! go to 1001 @@ -801,7 +801,7 @@ subroutine comqr2(nm,nl,low,igh,ortr,orti,hr,hi,wr,wi,zr,zi,ierr) 1001 return end subroutine comqr2 - subroutine cbabk2(nm,nl,low,igh,scale,ml,zr,zi) + subroutine cbabk2(nm, nl, low, igh, scale, ml, zr, zi) ! this subroutine is a translation of the algol procedure ! cbabk2, which is a complex version of balbak, ! num. math. 13, 293-304(1969) by parlett and reinsch. @@ -843,72 +843,72 @@ subroutine cbabk2(nm,nl,low,igh,scale,ml,zr,zi) ! ! ------------------------------------------------------------------ ! - integer i,j,k,ml,nl,ii,nm,igh,low - double precision scale(nl),zr(nm,ml),zi(nm,ml) - double precision s + integer i, j, k, ml, nl, ii, nm, igh, low + double precision scale(nl), zr(nm, ml), zi(nm, ml) + double precision s - if (ml .eq. 0) go to 200 - if (igh .eq. low) go to 120 + if (ml == 0) go to 200 + if (igh == low) go to 120 ! - do 110 i = low, igh - s = scale(i) + do 110 i = low, igh + s = scale(i) ! .......... left hand eigenvectors are back transformed ! if the foregoing statement is replaced by ! s=1.0d0/scale(i). .......... - do 100 j = 1, ml - zr(i,j) = zr(i,j) * s - zi(i,j) = zi(i,j) * s -100 continue + do 100 j = 1, ml + zr(i, j) = zr(i, j)*s + zi(i, j) = zi(i, j)*s +100 end do ! -110 continue +110 end do ! .......... for i=low-1 step -1 until 1, ! igh+1 step 1 until nl do -- .......... -120 do 140 ii = 1, nl - i = ii - if (i .ge. low .and. i .le. igh) go to 140 - if (i .lt. low) i = low - ii - k = scale(i) - if (k .eq. i) go to 140 -! - do 130 j = 1, ml - s = zr(i,j) - zr(i,j) = zr(k,j) - zr(k,j) = s - s = zi(i,j) - zi(i,j) = zi(k,j) - zi(k,j) = s -130 continue -! -140 continue -! -200 return +120 do 140 ii = 1, nl + i = ii + if (i >= low .and. i <= igh) go to 140 + if (i < low) i = low - ii + k = scale(i) + if (k == i) go to 140 +! + do 130 j = 1, ml + s = zr(i, j) + zr(i, j) = zr(k, j) + zr(k, j) = s + s = zi(i, j) + zi(i, j) = zi(k, j) + zi(k, j) = s +130 end do +! +140 end do +! +200 return end subroutine cbabk2 - - subroutine csroot(xr,xi,yr,yi) - real(kind(0d0)) :: xr,xi,yr,yi + + subroutine csroot(xr, xi, yr, yi) + real(kind(0d0)) :: xr, xi, yr, yi ! -! (yr,yi) = complex dsqrt(xr,xi) +! (yr,yi) = complex dsqrt(xr,xi) ! branch chosen so that yr .ge. 0.0 and sign(yi) .eq. sign(xi) ! - real(kind(0d0)) :: s,tr,ti,c + real(kind(0d0)) :: s, tr, ti, c tr = xr ti = xi - call pythag(tr,ti,c) + call pythag(tr, ti, c) s = dsqrt(0.5d0*(c + dabs(tr))) - if (tr .ge. 0.0d0) yr = s - if (ti .lt. 0.0d0) s = -s - if (tr .le. 0.0d0) yi = s - if (tr .lt. 0.0d0) yr = 0.5d0*(ti/yi) - if (tr .gt. 0.0d0) yi = 0.5d0*(ti/yr) + if (tr >= 0.0d0) yr = s + if (ti < 0.0d0) s = -s + if (tr <= 0.0d0) yi = s + if (tr < 0.0d0) yr = 0.5d0*(ti/yi) + if (tr > 0.0d0) yi = 0.5d0*(ti/yr) return end subroutine csroot - - subroutine cdiv(ar,ai,br,bi,cr,ci) - real(kind(0d0)) :: ar,ai,br,bi,cr,ci + + subroutine cdiv(ar, ai, br, bi, cr, ci) + real(kind(0d0)) :: ar, ai, br, bi, cr, ci ! ! complex division, (cr,ci) = (ar,ai)/(br,bi) ! - real(kind(0d0)) :: s,ars,ais,brs,bis + real(kind(0d0)) :: s, ars, ais, brs, bis s = dabs(br) + dabs(bi) ars = ar/s ais = ai/s @@ -920,25 +920,25 @@ subroutine cdiv(ar,ai,br,bi,cr,ci) return end subroutine cdiv - subroutine pythag(a,b,c) - real(kind(0d0)) :: a,b,c + subroutine pythag(a, b, c) + real(kind(0d0)) :: a, b, c ! ! finds dsqrt(a**2+b**2) without overflow or destructive underflow ! - real(kind(0d0)) :: p,r,s,t,u - p = dmax1(dabs(a),dabs(b)) - if (p .eq. 0.0d0) go to 20 - r = (dmin1(dabs(a),dabs(b))/p)**2 + real(kind(0d0)) :: p, r, s, t, u + p = dmax1(dabs(a), dabs(b)) + if (p == 0.0d0) go to 20 + r = (dmin1(dabs(a), dabs(b))/p)**2 10 continue t = 4.0d0 + r - if (t .eq. 4.0d0) go to 20 + if (t == 4.0d0) go to 20 s = r/t u = 1.0d0 + 2.0d0*s p = u*p - r = (s/u)**2 * r + r = (s/u)**2*r go to 10 20 c = p return end subroutine pythag -end module m_eigen_solver \ No newline at end of file +end module m_eigen_solver diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index 54424ff86..87589b055 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -6,7 +6,7 @@ module m_helper ! Dependencies ============================================================= - + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -16,19 +16,19 @@ module m_helper implicit none private; public :: s_compute_finite_difference_coefficients, & - s_comp_n_from_prim, & - s_comp_n_from_cons, & - s_initialize_nonpoly, & - s_simpson, & - s_transcoeff, & - s_int_to_str, & - s_transform_vec, & - s_transform_triangle, & - s_transform_model, & - s_swap, & - f_cross, & - f_create_transform_matrix, & - f_create_bbox + s_comp_n_from_prim, & + s_comp_n_from_cons, & + s_initialize_nonpoly, & + s_simpson, & + s_transcoeff, & + s_int_to_str, & + s_transform_vec, & + s_transform_triangle, & + s_transform_model, & + s_swap, & + f_cross, & + f_create_transform_matrix, & + f_create_bbox contains @@ -43,7 +43,7 @@ contains !! @param s_cc Locations of the cell-centers in the s-coordinate direction !! @param fd_coeff_s Finite-diff. coefficients in the s-coordinate direction subroutine s_compute_finite_difference_coefficients(q, s_cc, fd_coeff_s, buff_size, & - fd_number_in, fd_order_in, offset_s) + fd_number_in, fd_order_in, offset_s) integer :: lB, lE !< loop bounds integer, intent(IN) :: q @@ -63,9 +63,9 @@ contains else lB = 0 lE = q - endif + end if - if (allocated(fd_coeff_s)) deallocate(fd_coeff_s) + if (allocated(fd_coeff_s)) deallocate (fd_coeff_s) allocate (fd_coeff_s(-fd_number_in:fd_number_in, lb:lE)) ! Computing the 1st order finite-difference coefficients @@ -119,7 +119,7 @@ contains !$acc routine seq real(kind(0.d0)), intent(IN) :: vftmp real(kind(0.d0)), dimension(nb), intent(IN) :: nRtmp - real(kind(0.d0)), intent(OUT) :: ntmp + real(kind(0.d0)), intent(OUT) :: ntmp real(kind(0.d0)) :: nR3 real(kind(0.d0)), dimension(nb) :: weights @@ -131,7 +131,6 @@ contains end subroutine s_comp_n_from_cons - !> Initializes non-polydisperse bubble modeling subroutine s_initialize_nonpoly integer :: ir @@ -224,21 +223,21 @@ contains ! nondimensional properties !if(.not. qbmm) then - R_n = rhol0*R_n*temp/pl0 - R_v = rhol0*R_v*temp/pl0 - k_n = k_n/k_m0 - k_v = k_v/k_m0 - pb0 = pb0/pl0 - pv = pv/pl0 - Tw = 1.d0 - pl0 = 1.d0 - - rhoref = 1.d0 - pref = 1.d0 + R_n = rhol0*R_n*temp/pl0 + R_v = rhol0*R_v*temp/pl0 + k_n = k_n/k_m0 + k_v = k_v/k_m0 + pb0 = pb0/pl0 + pv = pv/pl0 + Tw = 1.d0 + pl0 = 1.d0 + + rhoref = 1.d0 + pref = 1.d0 !end if ! natural frequencies - omegaN = DSQRT(3.d0*k_poly*Ca + 2.d0*(3.d0*k_poly - 1.d0)/(Web*R0))/R0 + omegaN = DSQRT(3.d0*k_poly*Ca + 2.d0*(3.d0*k_poly - 1.d0)/(Web*R0))/R0 do ir = 1, Nb call s_transcoeff(omegaN(ir)*R0(ir), Pe_T(ir)*R0(ir), & Re_trans_T(ir), Im_trans_T(ir)) @@ -246,11 +245,10 @@ contains Re_trans_c(ir), Im_trans_c(ir)) end do Im_trans_T = 0d0 - - + end subroutine s_initialize_nonpoly - !> Computes the transfer coefficient for the non-polytropic bubble compression process + !> Computes the transfer coefficient for the non-polytropic bubble compression process !! @param omega natural frqeuencies !! @param peclet Peclet number !! @param Re_trans Real part of the transport coefficients @@ -277,12 +275,12 @@ contains subroutine s_int_to_str(i, res) character(len=*) :: res - integer,intent(in) :: i - write(res,'(I0)') i + integer, intent(in) :: i + write (res, '(I0)') i res = trim(res) end subroutine - !> Computes the Simpson weights for quadrature + !> Computes the Simpson weights for quadrature subroutine s_simpson integer :: ir @@ -333,18 +331,18 @@ contains tmp = DEXP(-0.5d0*(phi(nb)/sd)**2)/DSQRT(2.d0*pi)/sd weight(nb) = tmp*dphi/3.d0 end subroutine s_simpson - + !> This procedure computes the cross product of two vectors. !! @param a First vector. !! @param b Second vector. !! @return The cross product of the two vectors. function f_cross(a, b) result(c) real(kind(0d0)), dimension(3), intent(in) :: a, b - real(kind(0d0)), dimension(3) :: c + real(kind(0d0)), dimension(3) :: c - c(1) = a(2) * b(3) - a(3) * b(2) - c(2) = a(3) * b(1) - a(1) * b(3) - c(3) = a(1) * b(2) - a(2) * b(1) + c(1) = a(2)*b(3) - a(3)*b(2) + c(2) = a(3)*b(1) - a(1)*b(3) + c(3) = a(1)*b(2) - a(2)*b(1) end function f_cross !> This procedure swaps two real numbers. @@ -352,11 +350,11 @@ contains !! @param rhs Right-hand side. subroutine s_swap(lhs, rhs) real(kind(0d0)), intent(inout) :: lhs, rhs - real(kind(0d0)) :: ltemp + real(kind(0d0)) :: ltemp ltemp = lhs - lhs = rhs - rhs = ltemp + lhs = rhs + rhs = ltemp end subroutine s_swap !> This procedure creates a transformation matrix. @@ -369,34 +367,34 @@ contains t_mat4x4 :: sc, rz, rx, ry, tr, out_matrix sc = transpose(reshape([ & - p%scale(1), 0d0, 0d0, 0d0, & - 0d0, p%scale(2), 0d0, 0d0, & - 0d0, 0d0, p%scale(3), 0d0, & - 0d0, 0d0, 0d0, 1d0 ], shape(sc))) + p%scale(1), 0d0, 0d0, 0d0, & + 0d0, p%scale(2), 0d0, 0d0, & + 0d0, 0d0, p%scale(3), 0d0, & + 0d0, 0d0, 0d0, 1d0], shape(sc))) rz = transpose(reshape([ & - cos(p%rotate(3)), -sin(p%rotate(3)), 0d0, 0d0, & - sin(p%rotate(3)), cos(p%rotate(3)), 0d0, 0d0, & - 0d0, 0d0, 1d0, 0d0, & - 0d0, 0d0, 0d0, 1d0 ], shape(rz))) + cos(p%rotate(3)), -sin(p%rotate(3)), 0d0, 0d0, & + sin(p%rotate(3)), cos(p%rotate(3)), 0d0, 0d0, & + 0d0, 0d0, 1d0, 0d0, & + 0d0, 0d0, 0d0, 1d0], shape(rz))) rx = transpose(reshape([ & - 1d0, 0d0, 0d0, 0d0, & - 0d0, cos(p%rotate(1)), -sin(p%rotate(1)), 0d0, & - 0d0, sin(p%rotate(1)), cos(p%rotate(1)), 0d0, & - 0d0, 0d0, 0d0, 1d0 ], shape(rx))) + 1d0, 0d0, 0d0, 0d0, & + 0d0, cos(p%rotate(1)), -sin(p%rotate(1)), 0d0, & + 0d0, sin(p%rotate(1)), cos(p%rotate(1)), 0d0, & + 0d0, 0d0, 0d0, 1d0], shape(rx))) ry = transpose(reshape([ & - cos(p%rotate(2)), 0d0, sin(p%rotate(2)), 0d0, & - 0d0, 1d0, 0d0, 0d0, & - -sin(p%rotate(2)), 0d0, cos(p%rotate(2)), 0d0, & - 0d0, 0d0, 0d0, 1d0 ], shape(ry))) + cos(p%rotate(2)), 0d0, sin(p%rotate(2)), 0d0, & + 0d0, 1d0, 0d0, 0d0, & + -sin(p%rotate(2)), 0d0, cos(p%rotate(2)), 0d0, & + 0d0, 0d0, 0d0, 1d0], shape(ry))) tr = transpose(reshape([ & - 1d0, 0d0, 0d0, p%translate(1), & - 0d0, 1d0, 0d0, p%translate(2), & - 0d0, 0d0, 1d0, p%translate(3), & - 0d0, 0d0, 0d0, 1d0 ], shape(tr))) + 1d0, 0d0, 0d0, p%translate(1), & + 0d0, 1d0, 0d0, p%translate(2), & + 0d0, 0d0, 1d0, p%translate(3), & + 0d0, 0d0, 0d0, 1d0], shape(tr))) out_matrix = matmul(tr, matmul(ry, matmul(rx, matmul(rz, sc)))) @@ -407,12 +405,12 @@ contains !! @param matrix Transformation matrix. subroutine s_transform_vec(vec, matrix) - t_vec3, intent(inout) :: vec - t_mat4x4, intent(in) :: matrix + t_vec3, intent(inout) :: vec + t_mat4x4, intent(in) :: matrix real(kind(0d0)), dimension(1:4) :: tmp - tmp = matmul(matrix, [ vec(1), vec(2), vec(3), 1d0 ]) + tmp = matmul(matrix, [vec(1), vec(2), vec(3), 1d0]) vec = tmp(1:3) end subroutine s_transform_vec @@ -430,7 +428,7 @@ contains real(kind(0d0)), dimension(1:4) :: tmp do i = 1, 3 - call s_transform_vec(triangle%v(i,:), matrix) + call s_transform_vec(triangle%v(i, :), matrix) end do end subroutine s_transform_triangle @@ -441,7 +439,7 @@ contains subroutine s_transform_model(model, matrix) type(t_model), intent(inout) :: model - t_mat4x4, intent(in) :: matrix + t_mat4x4, intent(in) :: matrix integer :: i @@ -457,7 +455,7 @@ contains function f_create_bbox(model) result(bbox) type(t_model), intent(in) :: model - type(t_bbox) :: bbox + type(t_bbox) :: bbox integer :: i, j @@ -467,13 +465,13 @@ contains return end if - bbox%min = model%trs(1)%v(1,:) - bbox%max = model%trs(1)%v(1,:) + bbox%min = model%trs(1)%v(1, :) + bbox%max = model%trs(1)%v(1, :) do i = 1, size(model%trs) do j = 1, 3 - bbox%min = min(bbox%min, model%trs(i)%v(j,:)) - bbox%max = max(bbox%max, model%trs(i)%v(j,:)) + bbox%min = min(bbox%min, model%trs(i)%v(j, :)) + bbox%max = max(bbox%max, model%trs(i)%v(j, :)) end do end do diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 9683da10e..16b63afa2 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -27,7 +27,6 @@ module m_mpi_common contains - !> The subroutine initializes the MPI execution environment !! and queries both the number of processors which will be !! available for the job and the local processor rank. @@ -61,7 +60,6 @@ contains end subroutine s_mpi_initialize ! -------------------------------------- - subroutine s_initialize_mpi_data(q_cons_vf) ! -------------------------- type(scalar_field), & @@ -80,25 +78,25 @@ contains end do !Additional variables pb and mv for non-polytropic qbmm -#ifdef MFC_PRE_PROCESS - if(qbmm .and. .not. polytropic) then +#ifdef MFC_PRE_PROCESS + if (qbmm .and. .not. polytropic) then do i = 1, nb do j = 1, nnode - MPI_IO_DATA%var(sys_size + (i-1)*nnode + j)%sf => pb%sf(0:m, 0:n, 0:p, j, i) - MPI_IO_DATA%var(sys_size + (i-1)*nnode + j + nb*nnode)%sf => mv%sf(0:m, 0:n, 0:p, j, i) + MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j)%sf => pb%sf(0:m, 0:n, 0:p, j, i) + MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j + nb*nnode)%sf => mv%sf(0:m, 0:n, 0:p, j, i) end do - end do + end do end if #endif -#ifdef MFC_SIMULATION - if(qbmm .and. .not. polytropic) then +#ifdef MFC_SIMULATION + if (qbmm .and. .not. polytropic) then do i = 1, nb do j = 1, nnode - MPI_IO_DATA%var(sys_size + (i-1)*nnode + j)%sf => pb_ts(1)%sf(0:m, 0:n, 0:p, j, i) - MPI_IO_DATA%var(sys_size + (i-1)*nnode + j + nb*nnode)%sf => mv_ts(1)%sf(0:m, 0:n, 0:p, j, i) + MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j)%sf => pb_ts(1)%sf(0:m, 0:n, 0:p, j, i) + MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j + nb*nnode)%sf => mv_ts(1)%sf(0:m, 0:n, 0:p, j, i) end do - end do + end do end if #endif ! Define global(g) and local(l) sizes for flow variables @@ -118,11 +116,11 @@ contains end do #ifndef MFC_POST_PROCESS - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*4 - call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, & - MPI_ORDER_FORTRAN, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), ierr) - call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) + call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, & + MPI_ORDER_FORTRAN, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), ierr) + call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do end if @@ -132,7 +130,6 @@ contains end subroutine s_initialize_mpi_data ! --------------------------------- - subroutine mpi_bcast_time_step_values(proc_time, time_avg) real(kind(0d0)), dimension(0:num_procs - 1), intent(INOUT) :: proc_time @@ -146,7 +143,6 @@ contains end subroutine mpi_bcast_time_step_values - !> The goal of this subroutine is to determine the global !! extrema of the stability criteria in the computational !! domain. This is performed by sifting through the local @@ -203,7 +199,6 @@ contains end subroutine s_mpi_reduce_stability_criteria_extrema ! --------------- - !> The following subroutine takes the input local variable !! from all processors and reduces to the sum of all !! values. The reduced variable is recorded back onto the @@ -270,7 +265,6 @@ contains end subroutine s_mpi_allreduce_max ! ----------------------------------- - !> The following subroutine takes the inputted variable and !! determines its minimum value on the entire computational !! domain. The result is stored back into inputted variable. @@ -300,7 +294,6 @@ contains end subroutine s_mpi_reduce_min ! -------------------------------------- - !> The following subroutine takes the first element of the !! 2-element inputted variable and determines its maximum !! value on the entire computational domain. The result is @@ -343,8 +336,8 @@ contains character(len=*), intent(in), optional :: prnt if (present(prnt)) then - print*, prnt - call flush(6) + print *, prnt + call flush (6) end if @@ -353,7 +346,7 @@ contains stop 1 #else - + ! Terminating the MPI environment call MPI_ABORT(MPI_COMM_WORLD, 1, ierr) @@ -373,7 +366,6 @@ contains end subroutine s_mpi_barrier ! ----------------------------------------- - !> The subroutine finalizes the MPI execution environment. subroutine s_mpi_finalize() ! ------------------------------------------ @@ -386,5 +378,4 @@ contains end subroutine s_mpi_finalize ! ---------------------------------------- - end module m_mpi_common diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index c805ce82d..0c636c799 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -29,9 +29,9 @@ module m_phase_change implicit none private; public :: s_initialize_phasechange_module, & - s_relaxation_solver, & - s_infinite_relaxation_k, & - s_finalize_relaxation_solver_module + s_relaxation_solver, & + s_infinite_relaxation_k, & + s_finalize_relaxation_solver_module !> @name Abstract interface for creating function pointers !> @{ @@ -52,10 +52,10 @@ module m_phase_change !> @{ integer, parameter :: max_iter = 1e8 !< max # of iterations real(kind(0d0)), parameter :: pCr = 4.94d7 !< Critical water pressure - real(kind(0d0)), parameter :: TCr = 385.05+273.15 !< Critical water temperature + real(kind(0d0)), parameter :: TCr = 385.05 + 273.15 !< Critical water temperature real(kind(0d0)), parameter :: mixM = 1.0d-8 !< threshold for 'mixture cell'. If Y < mixM, phase change does not happen - integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid - integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid + integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid + integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid !> @} !> @name Gibbs free energy phase change parameters @@ -70,7 +70,7 @@ module m_phase_change contains !> The purpose of this subroutine is to initialize the phase change module - !! by setting the parameters needed for phase change and + !! by setting the parameters needed for phase change and !! selecting the phase change module that will be used !! (pT- or pTg-equilibrium) subroutine s_initialize_phasechange_module() @@ -109,7 +109,7 @@ contains real(kind(0.0d0)) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy real(kind(0.0d0)) :: rho, rM, m1, m2, MCT !< total density, total reacting mass, individual reacting masses real(kind(0.0d0)) :: TvF !< total volume fraction - + !$acc declare create(pS, pSOV, pSSL, TS, TSOV, TSatOV, TSatSL, TSSL, rhoe, dynE, rhos, rho, rM, m1, m2, MCT, TvF) real(kind(0d0)), dimension(num_fluids) :: p_infOV, p_infpT, p_infSL, sk, hk, gk, ek, rhok @@ -126,7 +126,7 @@ contains do l = 0, p rho = 0.0d0; TvF = 0.0d0 -!$acc loop seq + !$acc loop seq do i = 1, num_fluids ! Mixture density @@ -152,7 +152,7 @@ contains ! kinetic energy as an auxiliary variable to the calculation of the total internal energy dynE = 0.0d0 -!$acc loop seq + !$acc loop seq do i = momxb, momxe dynE = dynE + 5.0d-1*q_cons_vf(i)%sf(j, k, l)**2/rho @@ -172,9 +172,9 @@ contains ! NOTE that NOTHING else needs to be updated OTHER than the individual partial densities ! given the outputs from the pT- and pTg-equilibrium solvers are just p and one of the partial masses ! (pTg- case) - if ((relax_model == 6) .and. ((q_cons_vf(lp + contxb - 1)%sf(j, k, l) > mixM*rM) & - .and. (q_cons_vf(vp + contxb - 1)%sf(j, k, l) > mixM*rM)) & - .and. (pS < pCr) .and. (TS < TCr)) then + if ((relax_model == 6) .and. ((q_cons_vf(lp + contxb - 1)%sf(j, k, l) > mixM*rM) & + .and. (q_cons_vf(vp + contxb - 1)%sf(j, k, l) > mixM*rM)) & + .and. (pS < pCr) .and. (TS < TCr)) then ! Checking if phase change is needed, by checking whether the final solution is either subcoooled ! liquid or overheated vapor. @@ -250,11 +250,11 @@ contains end if - ! Calculations AFTER equilibrium - + ! Calculations AFTER equilibrium + ! entropy sk(1:num_fluids) = cvs(1:num_fluids)*DLOG((TS**gs_min(1:num_fluids)) & - /((pS + ps_inf(1:num_fluids))**(gs_min(1:num_fluids) - 1.0d0))) + qvps(1:num_fluids) + /((pS + ps_inf(1:num_fluids))**(gs_min(1:num_fluids) - 1.0d0))) + qvps(1:num_fluids) ! enthalpy hk(1:num_fluids) = gs_min(1:num_fluids)*cvs(1:num_fluids)*TS & @@ -274,7 +274,7 @@ contains ! calculating volume fractions, internal energies, and total entropy rhos = 0.0d0 -!$acc loop seq + !$acc loop seq do i = 1, num_fluids ! volume fractions @@ -294,9 +294,9 @@ contains end subroutine s_infinite_relaxation_k ! ---------------- !> This auxiliary subroutine is created to activate the pT-equilibrium for N fluids - !! @param j generic loop iterator for x direction - !! @param k generic loop iterator for y direction - !! @param l generic loop iterator for z direction + !! @param j generic loop iterator for x direction + !! @param k generic loop iterator for y direction + !! @param l generic loop iterator for z direction !! @param MFL flag that tells whether the fluid is pure gas (0), pure liquid (1), or a mixture (2) !! @param pS equilibrium pressure at the interface !! @param p_infpT stiffness for the participating fluids under pT-equilibrium @@ -305,19 +305,19 @@ contains !! @param rhoe mixture energy !! @param TS equilibrium temperature at the interface subroutine s_infinite_pt_relaxation_k(j, k, l, MFL, pS, p_infpT, rM, q_cons_vf, rhoe, TS) -!$acc routine seq + !$acc routine seq ! initializing variables type(scalar_field), dimension(sys_size), intent(IN) :: q_cons_vf - real(kind(0.0d0)), intent(OUT) :: pS, TS - real(kind(0.0d0)), dimension(num_fluids), intent(OUT) :: p_infpT - real(kind(0.0d0)), intent(IN) :: rM, rhoe - integer, intent(IN) :: j, k, l, MFL + real(kind(0.0d0)), intent(OUT) :: pS, TS + real(kind(0.0d0)), dimension(num_fluids), intent(OUT) :: p_infpT + real(kind(0.0d0)), intent(IN) :: rM, rhoe + integer, intent(IN) :: j, k, l, MFL real(kind(0.0d0)), dimension(num_fluids) :: pk !< individual initial pressures integer, dimension(num_fluids) :: ig !< flags to toggle the inclusion of fluids for the pT-equilibrium real(kind(0.0d0)) :: gp, gpp, hp, pO, mCP, mQ !< variables for the Newton Solver - + integer :: i, ns !< generic loop iterators ! auxiliary variables for the pT-equilibrium solver @@ -326,7 +326,7 @@ contains ig(1:num_fluids) = 0 ! Performing tests before initializing the pT-equilibrium -!$acc loop seq + !$acc loop seq do i = 1, num_fluids ! sum of the total alpha*rho*cp of the system @@ -366,7 +366,7 @@ contains ns = 0 ! change this relative error metric. 1E4 is just arbitrary do while ((DABS(pS - pO) > palpha_eps) .and. (DABS((pS - pO)/pO) > palpha_eps/1e4) .or. (ns == 0)) - + ! increasing counter ns = ns + 1 @@ -375,14 +375,14 @@ contains ! updating functions used in the Newton's solver gpp = 0.0d0; gp = 0.0d0; hp = 0.0d0 -!$acc loop seq + !$acc loop seq do i = 1, num_fluids - gp = gp + (gs_min(i) - 1.0d0)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i) & - *(rhoe + pS - mQ)/(mCP*(pS + p_infpT(i))) + gp = gp + (gs_min(i) - 1.0d0)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i) & + *(rhoe + pS - mQ)/(mCP*(pS + p_infpT(i))) - gpp = gpp + (gs_min(i) - 1.0d0)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i) & - *(p_infpT(i) - rhoe + mQ)/(mCP*(pS + p_infpT(i))**2) + gpp = gpp + (gs_min(i) - 1.0d0)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i) & + *(p_infpT(i) - rhoe + mQ)/(mCP*(pS + p_infpT(i))**2) end do @@ -400,16 +400,16 @@ contains !> This auxiliary subroutine is created to activate the pTg-equilibrium for N fluids under pT !! and 2 fluids under pTg-equilibrium. There is a final common p and T during relaxation - !! @param j generic loop iterator for x direction - !! @param k generic loop iterator for y direction - !! @param l generic loop iterator for z direction + !! @param j generic loop iterator for x direction + !! @param k generic loop iterator for y direction + !! @param l generic loop iterator for z direction !! @param pS equilibrium pressure at the interface !! @param p_infpT stiffness for the participating fluids under pT-equilibrium !! @param rhoe mixture energy !! @param q_cons_vf Cell-average conservative variables !! @param TS equilibrium temperature at the interface subroutine s_infinite_ptg_relaxation_k(j, k, l, pS, p_infpT, rhoe, q_cons_vf, TS) -!$acc routine seq + !$acc routine seq type(scalar_field), dimension(sys_size), intent(INOUT) :: q_cons_vf real(kind(0.0d0)), dimension(num_fluids), intent(IN) :: p_infpT @@ -437,7 +437,7 @@ contains if (((pS < 0.0d0) .and. ((q_cons_vf(lp + contxb - 1)%sf(j, k, l) & + q_cons_vf(vp + contxb - 1)%sf(j, k, l)) > ((rhoe & - - gs_min(lp)*ps_inf(lp)/(gs_min(lp) - 1))/qvs(lp)))) .or. & + - gs_min(lp)*ps_inf(lp)/(gs_min(lp) - 1))/qvs(lp)))) .or. & ((pS >= 0.0d0) .and. (pS < 1.0d-1))) then ! improve this initial condition @@ -463,7 +463,7 @@ contains mCP = 0.0d0; mCPD = 0.0d0; mCVGP = 0.0d0; mCVGP2 = 0.0d0; mQ = 0.0d0; mQD = 0.0d0 ! Those must be updated through the iterations, as they either depend on ! the partial masses for all fluids, or on the equilibrium pressure -!$acc loop seq + !$acc loop seq do i = 1, num_fluids ! sum of the total alpha*rho*cp of the system @@ -498,7 +498,7 @@ contains ! calculating correction array for Newton's method DeltamP = -1.0d0*matmul(InvJac, R2D) - + ! updating two reacting 'masses'. Recall that inert 'masses' do not change during the phase change ! liquid q_cons_vf(lp + contxb - 1)%sf(j, k, l) = q_cons_vf(lp + contxb - 1)%sf(j, k, l) + Om*DeltamP(1) @@ -521,7 +521,7 @@ contains end subroutine s_infinite_ptg_relaxation_k ! ----------------------- !> This auxiliary subroutine corrects the partial densities of the REACTING fluids in case one of them is negative - !! but their sum is positive. Inert phases are not corrected at this moment + !! but their sum is positive. Inert phases are not corrected at this moment !! @param MCT partial density correction parameter !! @param q_cons_vf Cell-average conservative variables !! @param rM sum of the reacting masses @@ -529,7 +529,7 @@ contains !! @param k generic loop iterator for y direction !! @param l generic loop iterator for z direction subroutine s_correct_partial_densities(MCT, q_cons_vf, rM, j, k, l) -!$acc routine seq + !$acc routine seq !> @name variables for the correction of the reacting partial densities !> @{ @@ -541,8 +541,8 @@ contains if (rM < 0.0d0) then - if ( (q_cons_vf(lp + contxb - 1)%sf(j, k, l) .ge. -1.0d0*mixM) .and. & - (q_cons_vf(vp + contxb - 1)%sf(j, k, l) .ge. -1.0d0*mixM) ) then + if ((q_cons_vf(lp + contxb - 1)%sf(j, k, l) >= -1.0d0*mixM) .and. & + (q_cons_vf(vp + contxb - 1)%sf(j, k, l) >= -1.0d0*mixM)) then q_cons_vf(lp + contxb - 1)%sf(j, k, l) = 0.0d0 @@ -550,7 +550,7 @@ contains rM = q_cons_vf(lp + contxb - 1)%sf(j, k, l) + q_cons_vf(vp + contxb - 1)%sf(j, k, l) - end if + end if end if @@ -576,7 +576,7 @@ contains end subroutine s_correct_partial_densities !> This auxiliary subroutine calculates the 2 x 2 Jacobian and, its inverse and transpose - !! to be used in the pTg-equilibirium procedure + !! to be used in the pTg-equilibirium procedure !! @param InvJac Inverse of the Jacobian Matrix !! @param j generic loop iterator for x direction !! @param Jac Jacobian Matrix @@ -586,11 +586,11 @@ contains !! @param mCVGP auxiliary variable for the calculation of the matrices: alpha*rho*cv*(g-1)/press !! @param mCVGP2 auxiliary variable for the calculation of the matrices: alpha*rho*cv*(g-1)/press^2 !! @param pS equilibrium pressure at the interface - !! @param q_cons_vf Cell-average conservative variables + !! @param q_cons_vf Cell-average conservative variables !! @param TJac Transpose of the Jacobian Matrix subroutine s_compute_jacobian_matrix(InvJac, j, Jac, k, l, mCPD, mCVGP, mCVGP2, pS, q_cons_vf, TJac) -!$acc routine seq - + !$acc routine seq + type(scalar_field), dimension(sys_size), intent(IN) :: q_cons_vf real(kind(0.0d0)), intent(IN) :: pS, mCPD, mCVGP, mCVGP2 integer, intent(IN) :: j, k, l @@ -682,12 +682,12 @@ contains !! @param mCPD sum of the total alpha*rho*cp !! @param mCVGP auxiliary variable for the calculation of the matrices: alpha*rho*cv*(g-1)/press !! @param mQD sum of the total alpha*rho*qv - !! @param q_cons_vf Cell-average conservative variables + !! @param q_cons_vf Cell-average conservative variables !! @param pS equilibrium pressure at the interface !! @param rhoe mixture energy !! @param R2D (2D) residue array subroutine s_compute_pTg_residue(j, k, l, mCPD, mCVGP, mQD, q_cons_vf, pS, rhoe, R2D) -!$acc routine seq + !$acc routine seq type(scalar_field), dimension(sys_size), intent(IN) :: q_cons_vf real(kind(0.0d0)), intent(IN) :: pS, rhoe, mCPD, mCVGP, mQD @@ -725,13 +725,13 @@ contains end subroutine s_compute_pTg_residue - !> This auxiliary subroutine finds the Saturation temperature for a given + !> This auxiliary subroutine finds the Saturation temperature for a given !! saturation pressure through a newton solver !! @param pSat Saturation Pressure !! @param TSat Saturation Temperature - !! @param TSIn equilibrium Temperature + !! @param TSIn equilibrium Temperature subroutine s_TSat(pSat, TSat, TSIn) -!$acc routine seq + !$acc routine seq real(kind(0.0d0)), intent(OUT) :: TSat real(kind(0.0d0)), intent(IN) :: pSat, TSIn @@ -762,10 +762,10 @@ contains ! calculating residual FT = TSat*((cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp)) & - *(1 - DLOG(TSat)) - (qvps(lp) - qvps(vp)) & - + cvs(lp)*(gs_min(lp) - 1)*DLOG(pSat + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)*DLOG(pSat + ps_inf(vp))) & - + qvs(lp) - qvs(vp) + *(1 - DLOG(TSat)) - (qvps(lp) - qvps(vp)) & + + cvs(lp)*(gs_min(lp) - 1)*DLOG(pSat + ps_inf(lp)) & + - cvs(vp)*(gs_min(vp) - 1)*DLOG(pSat + ps_inf(vp))) & + + qvs(lp) - qvs(vp) ! calculating the jacobian dFdT = & @@ -773,10 +773,10 @@ contains - (qvps(lp) - qvps(vp)) & + cvs(lp)*(gs_min(lp) - 1)*DLOG(pSat + ps_inf(lp)) & - cvs(vp)*(gs_min(vp) - 1)*DLOG(pSat + ps_inf(vp)) - + ! updating saturation temperature - TSat = TSat - Om * FT/dFdT - + TSat = TSat - Om*FT/dFdT + end do end if @@ -787,9 +787,9 @@ contains subroutine s_finalize_relaxation_solver_module() s_relaxation_solver => null() - + end subroutine #endif -end module m_phase_change \ No newline at end of file +end module m_phase_change diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 5b1056449..62dedc9fb 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -86,11 +86,11 @@ module m_variables_conversion !! In simulation, gammas, pi_infs, and qvs are already declared in m_global_variables #ifndef MFC_SIMULATION real(kind(0d0)), allocatable, public, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps - !$acc declare create(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps) +!$acc declare create(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps) #endif - real(kind(0d0)), allocatable, dimension(:) :: Gs - integer, allocatable, dimension(:) :: bubrs + real(kind(0d0)), allocatable, dimension(:) :: Gs + integer, allocatable, dimension(:) :: bubrs real(kind(0d0)), allocatable, dimension(:, :) :: Res !$acc declare create(bubrs, Gs, Res) @@ -105,7 +105,7 @@ module m_variables_conversion procedure(s_convert_xxxxx_to_mixture_variables), & pointer :: s_convert_to_mixture_variables => null() !< !! Pointer referencing the subroutine s_convert_mixture_to_mixture_variables - !! or s_convert_species_to_mixture_variables, based on model equations choice + !! or s_convert_species_to_mixture_variables, based on model equations choice contains @@ -120,9 +120,9 @@ contains !! @param gamma Specific Heat Ratio !! @param pres Pressure to calculate subroutine s_compute_pressure(energy, alf, dyn_p, pi_inf, gamma, rho, qv, pres, stress, mom, G) -!$acc routine seq + !$acc routine seq - real(kind(0d0)), intent(IN) :: energy, alf + real(kind(0d0)), intent(IN) :: energy, alf real(kind(0d0)), intent(IN), optional :: stress, mom, G real(kind(0d0)), intent(IN) :: dyn_p @@ -137,18 +137,18 @@ contains ! Depending on model_eqns and bubbles, the appropriate procedure ! for computing pressure is targeted by the procedure pointer - if ((model_eqns /= 4) .and. (bubbles .neqv. .true.)) then + if ((model_eqns /= 4) .and. (bubbles .neqv. .true.)) then pres = (energy - dyn_p - pi_inf - qv)/gamma else if ((model_eqns /= 4) .and. bubbles) then pres = ((energy - dyn_p)/(1.d0 - alf) - pi_inf - qv)/gamma else pres = (pref + pi_inf)* & - (energy/ & - (rhoref*(1 - alf)) & - )**(1/gamma + 1) - pi_inf + (energy/ & + (rhoref*(1 - alf)) & + )**(1/gamma + 1) - pi_inf end if - if (hypoelasticity .and. present(G)) then + if (hypoelasticity .and. present(G)) then ! calculate elastic contribution to Energy E_e = 0d0 do s = stress_idx%beg, stress_idx%end @@ -169,9 +169,6 @@ contains pi_inf - qv - E_e & )/gamma - - - end if end subroutine s_compute_pressure @@ -212,11 +209,10 @@ contains pi_inf = q_vf(pi_inf_idx)%sf(i, j, k) qv = 0d0 ! keep this value nill for now. For future adjustment - ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated #ifdef MFC_POST_PROCESS - rho_sf (i, j, k) = rho - gamma_sf (i, j, k) = gamma + rho_sf(i, j, k) = rho + gamma_sf(i, j, k) = gamma pi_inf_sf(i, j, k) = pi_inf qv_sf(i, j, k) = qv #endif @@ -321,28 +317,28 @@ contains #ifdef MFC_SIMULATION ! Computing the shear and bulk Reynolds numbers from species analogs - if (any(Re_size > 0)) then + if (any(Re_size > 0)) then if (num_fluids == 1) then ! need to consider case with num_fluids >= 2 do i = 1, 2 Re_K(i) = dflt_real; if (Re_size(i) > 0) Re_K(i) = 0d0 do q = 1, Re_size(i) - Re_K(i) = (1-alpha_K(Re_idx(i, q)))/fluid_pp(Re_idx(i, q))%Re(i) & - + Re_K(i) + Re_K(i) = (1 - alpha_K(Re_idx(i, q)))/fluid_pp(Re_idx(i, q))%Re(i) & + + Re_K(i) end do Re_K(i) = 1d0/max(Re_K(i), sgm_eps) end do end if - end if + end if #endif ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated #ifdef MFC_POST_PROCESS - rho_sf (j, k, l) = rho - gamma_sf (j, k, l) = gamma + rho_sf(j, k, l) = rho + gamma_sf(j, k, l) = gamma pi_inf_sf(j, k, l) = pi_inf qv_sf(j, k, l) = qv #endif @@ -441,8 +437,8 @@ contains ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated #ifdef MFC_POST_PROCESS - rho_sf (k, l, r) = rho - gamma_sf (k, l, r) = gamma + rho_sf(k, l, r) = rho + gamma_sf(k, l, r) = gamma pi_inf_sf(k, l, r) = pi_inf qv_sf(k, l, r) = qv #endif @@ -453,7 +449,7 @@ contains gamma_K, pi_inf_K, qv_K, & alpha_K, alpha_rho_K, Re_K, k, l, r, & G_K, G) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(OUT) :: rho_K, gamma_K, pi_inf_K, qv_K @@ -531,7 +527,7 @@ contains subroutine s_convert_species_to_mixture_variables_bubbles_acc(rho_K, & gamma_K, pi_inf_K, qv_K, & alpha_K, alpha_rho_K, Re_K, k, l, r) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(INOUT) :: rho_K, gamma_K, pi_inf_K, qv_K @@ -579,8 +575,8 @@ contains if (Re_size(i) > 0) Re_K(i) = 0d0 do j = 1, Re_size(i) - Re_K(i) = (1d0-alpha_K(Re_idx(i, j)))/Res(i, j) & - + Re_K(i) + Re_K(i) = (1d0 - alpha_K(Re_idx(i, j)))/Res(i, j) & + + Re_K(i) end do Re_K(i) = 1d0/max(Re_K(i), sgm_eps) @@ -600,8 +596,8 @@ contains integer :: i, j #ifdef MFC_PRE_PROCESS - ixb = 0; iyb = 0; izb = 0; - ixe = m; iye = n; ize = p; + ixb = 0; iyb = 0; izb = 0; + ixe = m; iye = n; ize = p; #else ixb = -buff_size ixe = m - ixb @@ -613,7 +609,7 @@ contains if (p > 0) then izb = -buff_size; ize = p - izb end if - end if + end if #endif !$acc update device(ixb, ixe, iyb, iye, izb, ize) @@ -628,28 +624,28 @@ contains @:ALLOCATE(Gs (1:num_fluids)) do i = 1, num_fluids - gammas(i) = fluid_pp(i)%gamma + gammas(i) = fluid_pp(i)%gamma gs_min(i) = 1.0d0/gammas(i) + 1.0d0 pi_infs(i) = fluid_pp(i)%pi_inf - Gs(i) = fluid_pp(i)%G + Gs(i) = fluid_pp(i)%G ps_inf(i) = pi_infs(i)/(1.0d0 + gammas(i)) cvs(i) = fluid_pp(i)%cv qvs(i) = fluid_pp(i)%qv qvps(i) = fluid_pp(i)%qvp end do - !$acc update device(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs) +!$acc update device(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs) #ifdef MFC_SIMULATION if (any(Re_size > 0)) then @: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 if #endif @@ -684,8 +680,8 @@ contains -buff_size:n + buff_size, & -buff_size:p + buff_size)) allocate (qv_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - -buff_size:p + buff_size)) + -buff_size:n + buff_size, & + -buff_size:p + buff_size)) ! Simulation is 2D else @@ -717,8 +713,8 @@ contains 0:0, & 0:0)) allocate (qv_sf(-buff_size:m + buff_size, & - 0:0, & - 0:0)) + 0:0, & + 0:0)) end if #endif @@ -737,72 +733,66 @@ contains end if end subroutine s_initialize_variables_conversion_module ! -------------- - !Initialize mv at the quadrature nodes based on the initialized moments and sigma - subroutine s_initialize_mv(qK_cons_vf, mv) - type(scalar_field), dimension(sys_size), intent(IN) :: qK_cons_vf - real(kind(0d0)), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(INOUT) :: mv - integer :: i, j, k, l - real(kind(0d0)) :: mu, sig, nbub_sc - + !Initialize mv at the quadrature nodes based on the initialized moments and sigma + subroutine s_initialize_mv(qK_cons_vf, mv) + type(scalar_field), dimension(sys_size), intent(IN) :: qK_cons_vf + real(kind(0d0)), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(INOUT) :: mv + integer :: i, j, k, l + real(kind(0d0)) :: mu, sig, nbub_sc - do l = izb, ize + do l = izb, ize do k = iyb, iye do j = ixb, ixe - + nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) - + !$acc loop seq do i = 1, nb - mu = qK_cons_vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l)/nbub_sc - sig = (qK_cons_vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l) / nbub_sc - mu**2)**0.5 + mu = qK_cons_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc + sig = (qK_cons_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc - mu**2)**0.5 - mv(j, k, l, 1, i) = (mass_v0(i)) * (mu - sig)**(3d0) / (R0(i)**(3d0)) - mv(j, k, l, 2, i) = (mass_v0(i)) * (mu - sig)**(3d0) / (R0(i)**(3d0)) - mv(j, k, l, 3, i) = (mass_v0(i)) * (mu + sig)**(3d0) / (R0(i)**(3d0)) - mv(j, k, l, 4, i) = (mass_v0(i)) * (mu + sig)**(3d0) / (R0(i)**(3d0)) - end do + mv(j, k, l, 1, i) = (mass_v0(i))*(mu - sig)**(3d0)/(R0(i)**(3d0)) + mv(j, k, l, 2, i) = (mass_v0(i))*(mu - sig)**(3d0)/(R0(i)**(3d0)) + mv(j, k, l, 3, i) = (mass_v0(i))*(mu + sig)**(3d0)/(R0(i)**(3d0)) + mv(j, k, l, 4, i) = (mass_v0(i))*(mu + sig)**(3d0)/(R0(i)**(3d0)) + end do end do end do end do - end subroutine s_initialize_mv !Initialize pb at the quadrature nodes using isothermal relations (Preston model) subroutine s_initialize_pb(qK_cons_vf, mv, pb) - + type(scalar_field), dimension(sys_size), intent(IN) :: qK_cons_vf - real(kind(0d0)), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(IN) :: mv + real(kind(0d0)), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(IN) :: mv real(kind(0d0)), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(INOUT) :: pb - integer :: i, j, k, l - real(kind(0d0)) :: mu, sig, nbub_sc - + integer :: i, j, k, l + real(kind(0d0)) :: mu, sig, nbub_sc - do l = izb, ize + do l = izb, ize do k = iyb, iye do j = ixb, ixe nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) - + !$acc loop seq do i = 1, nb - mu = qK_cons_vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l)/nbub_sc - sig = (qK_cons_vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l) / nbub_sc - mu**2)**0.5 + mu = qK_cons_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc + sig = (qK_cons_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc - mu**2)**0.5 !PRESTON (ISOTHERMAL) - pb(j, k, l, 1, i) = (pb0(i)) * (R0(i)**(3d0)) * (mass_n0(i) + mv(j, k, l, 1, i)) / (mu - sig)**(3d0) / (mass_n0(i) + mass_v0(i)) - pb(j, k, l, 2, i) = (pb0(i)) * (R0(i)**(3d0)) * (mass_n0(i) + mv(j, k, l, 2, i)) / (mu - sig)**(3d0) / (mass_n0(i) + mass_v0(i)) - pb(j, k, l, 3, i) = (pb0(i)) * (R0(i)**(3d0)) * (mass_n0(i) + mv(j, k, l, 3, i)) / (mu + sig)**(3d0) / (mass_n0(i) + mass_v0(i)) - pb(j, k, l, 4, i) = (pb0(i)) * (R0(i)**(3d0)) * (mass_n0(i) + mv(j, k, l, 4, i)) / (mu + sig)**(3d0) / (mass_n0(i) + mass_v0(i)) + pb(j, k, l, 1, i) = (pb0(i))*(R0(i)**(3d0))*(mass_n0(i) + mv(j, k, l, 1, i))/(mu - sig)**(3d0)/(mass_n0(i) + mass_v0(i)) + pb(j, k, l, 2, i) = (pb0(i))*(R0(i)**(3d0))*(mass_n0(i) + mv(j, k, l, 2, i))/(mu - sig)**(3d0)/(mass_n0(i) + mass_v0(i)) + pb(j, k, l, 3, i) = (pb0(i))*(R0(i)**(3d0))*(mass_n0(i) + mv(j, k, l, 3, i))/(mu + sig)**(3d0)/(mass_n0(i) + mass_v0(i)) + pb(j, k, l, 4, i) = (pb0(i))*(R0(i)**(3d0))*(mass_n0(i) + mv(j, k, l, 4, i))/(mu + sig)**(3d0)/(mass_n0(i) + mass_v0(i)) end do end do end do end do - - - end subroutine s_initialize_pb !> The following procedure handles the conversion between @@ -833,9 +823,9 @@ contains #:if MFC_CASE_OPTIMIZATION #ifndef MFC_SIMULATION - real(kind(0d0)), dimension(:), allocatable :: nRtmp + real(kind(0d0)), dimension(:), allocatable :: nRtmp #else - real(kind(0d0)), dimension(nb) :: nRtmp + real(kind(0d0)), dimension(nb) :: nRtmp #endif #:else real(kind(0d0)), dimension(:), allocatable :: nRtmp @@ -848,23 +838,23 @@ contains real(kind(0d0)) :: pres integer :: i, j, k, l !< Generic loop iterators - + real(kind(0.d0)) :: ntmp - + #:if MFC_CASE_OPTIMIZATION #ifndef MFC_SIMULATION - if (bubbles) then - allocate(nRtmp(nb)) - else - allocate(nRtmp(0)) - endif + if (bubbles) then + allocate (nRtmp(nb)) + else + allocate (nRtmp(0)) + end if #endif #:else - if (bubbles) then - allocate(nRtmp(nb)) - else - allocate(nRtmp(0)) - endif + if (bubbles) then + allocate (nRtmp(nb)) + else + allocate (nRtmp(0)) + end if #:endif !$acc parallel loop collapse(3) gang vector default(present) private(alpha_K, alpha_rho_K, Re_K, nRtmp, rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K, R3tmp) @@ -872,7 +862,7 @@ contains do k = iyb, iye do j = ixb, ixe dyn_pres_K = 0d0 - + !$acc loop seq do i = 1, num_fluids alpha_rho_K(i) = qK_cons_vf(i)%sf(j, k, l) @@ -884,8 +874,6 @@ contains qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) end do - - if (model_eqns /= 4) then #ifdef MFC_SIMULATION ! If in simulation, use acc mixture subroutines @@ -894,13 +882,13 @@ contains alpha_rho_K, Re_K, j, k, l, G_K, Gs) else if (bubbles) then call s_convert_species_to_mixture_variables_bubbles_acc(rho_K, gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K, j, k, l) - else + alpha_K, alpha_rho_K, Re_K, j, k, l) + else call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K, j, k, l) + alpha_K, alpha_rho_K, Re_K, j, k, l) end if #else - ! If pre-processing, use non acc mixture subroutines + ! If pre-processing, use non acc mixture subroutines if (hypoelasticity) then call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, & rho_K, gamma_K, pi_inf_K, qv_K, Re_K, G_K, fluid_pp(:)%G) @@ -942,28 +930,28 @@ contains vftmp = qK_cons_vf(alf_idx)%sf(j, k, l) - if(qbmm) then + if (qbmm) then !Get nb (constant across all R0 bins) nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) - !Convert cons to prim + !Convert cons to prim !$acc loop seq - do i = bubxb , bubxe + do i = bubxb, bubxe qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/nbub_sc end do !Need to keep track of nb in the primitive variable list (converted back to true value before output) -#ifdef MFC_SIMULATION - qK_prim_vf(bubxb)%sf(j, k, l) = qK_cons_vf(bubxb)%sf(j, k, l) +#ifdef MFC_SIMULATION + qK_prim_vf(bubxb)%sf(j, k, l) = qK_cons_vf(bubxb)%sf(j, k, l) #endif - else + else call s_comp_n_from_cons(vftmp, nRtmp, nbub_sc, weight) !$acc loop seq do i = bubxb, bubxe qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/nbub_sc - end do - end if + end do + end if end if if (hypoelasticity) then @@ -1097,17 +1085,17 @@ contains Rtmp(i) = q_prim_vf(bub_idx%rs(i))%sf(j, k, l) end do - if(.not. qbmm) then + if (.not. qbmm) then call s_comp_n_from_prim(q_prim_vf(alf_idx)%sf(j, k, l), Rtmp, nbub, weight) else !Initialize R3 averaging over R0 and R directions R3tmp = 0d0 do i = 1, nb - R3tmp = R3tmp + weight(i) * 0.5d0 * (Rtmp(i) + sigR) ** 3d0 - R3tmp = R3tmp + weight(i) * 0.5d0 * (Rtmp(i) - sigR) ** 3d0 + R3tmp = R3tmp + weight(i)*0.5d0*(Rtmp(i) + sigR)**3d0 + R3tmp = R3tmp + weight(i)*0.5d0*(Rtmp(i) - sigR)**3d0 end do - !Initialize nb - nbub = 3d0 * q_prim_vf(alf_idx)%sf(j, k, l) / (4d0 * pi * R3tmp) + !Initialize nb + nbub = 3d0*q_prim_vf(alf_idx)%sf(j, k, l)/(4d0*pi*R3tmp) end if if (j == 0 .and. k == 0 .and. l == 0) print *, 'In convert, nbub:', nbub @@ -1143,8 +1131,8 @@ contains #else if (proc_rank == 0) then call s_mpi_abort('Conversion from primitive to '// & - 'conservative variables not '// & - 'implemented. Exiting ...') + 'conservative variables not '// & + 'implemented. Exiting ...') end if #endif @@ -1197,27 +1185,27 @@ contains ! Computing the flux variables from the primitive variables, without ! accounting for the contribution of either viscosity or capillarity #ifdef MFC_SIMULATION -!$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_K, vel_K, alpha_K, Re_K) + !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_K, vel_K, alpha_K, Re_K) do l = is3b, is3e do k = is2b, is2e do j = is1b, is1e -!$acc loop seq + !$acc loop seq do i = 1, contxe alpha_rho_K(i) = qK_prim_vf(j, k, l, i) end do -!$acc loop seq + !$acc loop seq do i = advxb, advxe alpha_K(i - E_idx) = qK_prim_vf(j, k, l, i) end do -!$acc loop seq + !$acc loop seq do i = 1, num_dims vel_K(i) = qK_prim_vf(j, k, l, contxe + i) end do vel_K_sum = 0d0 -!$acc loop seq + !$acc loop seq do i = 1, num_dims vel_K_sum = vel_K_sum + vel_K(i)**2d0 end do @@ -1227,8 +1215,8 @@ contains call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & alpha_K, alpha_rho_K, Re_K, & j, k, l, G_K, Gs) - else if (bubbles) then - call s_convert_species_to_mixture_variables_bubbles_acc(rho_K, gamma_K, & + else if (bubbles) then + call s_convert_species_to_mixture_variables_bubbles_acc(rho_K, gamma_K, & pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K, j, k, l) else call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & @@ -1240,12 +1228,12 @@ contains + 5d-1*rho_K*vel_K_sum + qv_K ! mass flux, this should be \alpha_i \rho_i u_i -!$acc loop seq + !$acc loop seq do i = 1, contxe FK_vf(j, k, l, i) = alpha_rho_K(i)*vel_K(dir_idx(1)) end do -!$acc loop seq + !$acc loop seq do i = 1, num_dims FK_vf(j, k, l, contxe + dir_idx(i)) = & rho_K*vel_K(dir_idx(1)) & @@ -1258,7 +1246,7 @@ contains ! have been using == 2 if (riemann_solver == 1) then -!$acc loop seq + !$acc loop seq do i = advxb, advxe FK_vf(j, k, l, i) = 0d0 FK_src_vf(j, k, l, i) = alpha_K(i - E_idx) @@ -1266,12 +1254,12 @@ contains else ! Could be bubbles! -!$acc loop seq + !$acc loop seq do i = advxb, advxe FK_vf(j, k, l, i) = vel_K(dir_idx(1))*alpha_K(i - E_idx) end do -!$acc loop seq + !$acc loop seq do i = advxb, advxe FK_src_vf(j, k, l, i) = vel_K(dir_idx(1)) end do @@ -1289,11 +1277,11 @@ contains ! Deallocating the density, the specific heat ratio function and the ! liquid stiffness function #ifdef MFC_POST_PROCESS - deallocate(rho_sf, gamma_sf, pi_inf_sf, qv_sf) + deallocate (rho_sf, gamma_sf, pi_inf_sf, qv_sf) #endif @:DEALLOCATE(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs) - + if (bubbles) then @:DEALLOCATE(bubrs) end if diff --git a/src/post_process/m_checker.f90 b/src/post_process/m_checker.f90 index e7a3d932e..88a9bbaf2 100644 --- a/src/post_process/m_checker.f90 +++ b/src/post_process/m_checker.f90 @@ -2,7 +2,7 @@ !! @file m_checker.f90 !! @brief Contains module m_checker -!> @brief The purpose of the module is to check for compatible input files +!> @brief The purpose of the module is to check for compatible input files module m_checker use m_global_parameters !< Definitions of the global parameters @@ -29,38 +29,38 @@ subroutine s_check_inputs() ! Constraints on dimensionality and the number of cells for the grid if (m <= 0) then call s_mpi_abort('Unsupported choice for the value of m. '// & - 'Exiting ...') + 'Exiting ...') elseif (n < 0) then call s_mpi_abort('Unsupported choice for the value of n. '// & - 'Exiting ...') + 'Exiting ...') elseif (p < 0) then call s_mpi_abort('Unsupported choice for the value of p. '// & - 'Exiting ...') + 'Exiting ...') elseif (cyl_coord .and. p > 0 .and. mod(p, 2) /= 1) then call s_mpi_abort('Unsupported choice for the value of p. '// & - 'Exiting ...') + 'Exiting ...') elseif (n == 0 .and. p > 0) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and p. Exiting ...') + 'values for n and p. Exiting ...') elseif ((m + 1)*(n + 1)*(p + 1) & < & 2**(min(1, m) + min(1, n) + min(1, p))*num_procs) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for num_procs, m, n and p. '// & - 'Exiting ...') + 'values for num_procs, m, n and p. '// & + 'Exiting ...') ! Constraints on the time-stepping parameters elseif (t_step_start < 0) then call s_mpi_abort('Unsupported choice for the value of '// & - 't_step_start. Exiting ...') + 't_step_start. Exiting ...') elseif (t_step_stop < t_step_start) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for t_step_start and t_step_stop. '// & - 'Exiting ...') + 'values for t_step_start and t_step_stop. '// & + 'Exiting ...') elseif (t_step_save > t_step_stop - t_step_start) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for t_step_start, t_step_stop and '// & - 't_step_save. Exiting ...') + 'values for t_step_start, t_step_stop and '// & + 't_step_save. Exiting ...') ! Constraints on model equations and number of fluids in the flow elseif (all(model_eqns /= (/1, 2, 3, 4/))) then @@ -75,49 +75,49 @@ subroutine s_check_inputs() .or. & (model_eqns == 3 .and. num_fluids == dflt_int)) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns and num_fluids. '// & - 'Exiting ...') + 'model_eqns and num_fluids. '// & + 'Exiting ...') elseif (model_eqns == 1 .and. adv_alphan) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns and adv_alphan. '// & - 'Exiting ...') + 'model_eqns and adv_alphan. '// & + 'Exiting ...') ! Constraints on the order of the WENO scheme elseif (weno_order /= 1 .and. weno_order /= 3 & .and. & weno_order /= 5) then call s_mpi_abort('Unsupported choice for the value of '// & - 'weno_order. Exiting ...') - elseif (m + 1 < weno_order) then + 'weno_order. Exiting ...') + elseif (m + 1 < weno_order) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for m and weno_order. Exiting ...') + 'values for m and weno_order. Exiting ...') elseif (n > 0 .and. n + 1 < weno_order) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and weno_order. Exiting ...') - elseif (p > 0 .and. p + 1 < weno_order) then + 'values for n and weno_order. Exiting ...') + elseif (p > 0 .and. p + 1 < weno_order) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p and weno_order. Exiting ...') + 'values for p and weno_order. Exiting ...') elseif ((m + 1)*(n + 1)*(p + 1) & < & weno_order**(min(1, m) + min(1, n) + min(1, p))*num_procs) & then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for num_procs, m, n, p and '// & - 'weno_order. Exiting ...') + 'values for num_procs, m, n, p and '// & + 'weno_order. Exiting ...') ! Constraints on the boundary conditions in the x-direction elseif (bc_x%beg < -16 .or. bc_x%beg > -1 .or. bc_x%beg == -14) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_x%beg. Exiting ...') + 'bc_x%beg. Exiting ...') elseif (bc_x%end < -16 .or. bc_x%end > -1 .or. bc_x%beg == -14) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_x%end. Exiting ...') + 'bc_x%end. Exiting ...') elseif ((bc_x%beg == -1 .and. bc_x%end /= -1) & .or. & (bc_x%end == -1 .and. bc_x%beg /= -1)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for bc_x%beg and bc_x%end. '// & - 'Exiting ...') + 'values for bc_x%beg and bc_x%end. '// & + 'Exiting ...') ! Constraints on the boundary conditions in the y-direction elseif (bc_y%beg /= dflt_int & @@ -132,127 +132,127 @@ subroutine s_check_inputs() .and. & (bc_y%beg < -16 .or. bc_y%beg > -1)))) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_y%beg. Exiting ...') + 'bc_y%beg. Exiting ...') elseif (bc_y%end /= dflt_int & .and. & (bc_y%end < -16 .or. bc_y%end > -1 .or. bc_y%end == -14)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_y%end. Exiting ...') + 'bc_y%end. Exiting ...') elseif ((n == 0 .and. bc_y%beg /= dflt_int) & .or. & (n > 0 .and. bc_y%beg == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of n and '// & - 'bc_y%beg. Exiting ...') + 'bc_y%beg. Exiting ...') elseif ((n == 0 .and. bc_y%end /= dflt_int) & .or. & - (n > 0 .and. bc_y%end == dflt_int)) then + (n > 0 .and. bc_y%end == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of n and '// & - 'bc_y%end. Exiting ...') + 'bc_y%end. Exiting ...') elseif (n > 0 & .and. & ((bc_y%beg == -1 .and. bc_y%end /= -1) & .or. & (bc_y%end == -1 .and. bc_y%beg /= -1))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n, bc_y%beg and bc_y%end. '// & - 'Exiting ...') + 'values for n, bc_y%beg and bc_y%end. '// & + 'Exiting ...') ! Constraints on the boundary conditions in the z-direction elseif (bc_z%beg /= dflt_int & .and. & (bc_z%beg < -16 .or. bc_z%beg > -1 .or. bc_z%beg == -14)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_z%beg. Exiting ...') + 'bc_z%beg. Exiting ...') elseif (bc_z%end /= dflt_int & .and. & - (bc_z%end < -16 .or. bc_z%end > -1 .or. bc_z%end == -14)) then + (bc_z%end < -16 .or. bc_z%end > -1 .or. bc_z%end == -14)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_z%end. Exiting ...') + 'bc_z%end. Exiting ...') elseif (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == -13)) then call s_mpi_abort('Unsupported choice of boundary condition -13') elseif ((p == 0 .and. bc_z%beg /= dflt_int) & .or. & - (p > 0 .and. bc_z%beg == dflt_int)) then + (p > 0 .and. bc_z%beg == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of p and '// & - 'bc_z%beg. Exiting ...') + 'bc_z%beg. Exiting ...') elseif ((p == 0 .and. bc_z%end /= dflt_int) & .or. & (p > 0 .and. bc_z%end == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of p and '// & - 'bc_z%end. Exiting ...') + 'bc_z%end. Exiting ...') elseif (p > 0 & .and. & ((bc_z%beg == -1 .and. bc_z%end /= -1) & .or. & - (bc_z%end == -1 .and. bc_z%beg /= -1))) then + (bc_z%end == -1 .and. bc_z%beg /= -1))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p, bc_z%beg and bc_z%end. '// & - 'Exiting ...') + 'values for p, bc_z%beg and bc_z%end. '// & + 'Exiting ...') end if ! Constraints on the stiffened equation of state fluids parameters do i = 1, num_fluids - call s_int_to_str(i,iStr) + call s_int_to_str(i, iStr) if (fluid_pp(i)%gamma /= dflt_real & .and. & fluid_pp(i)%gamma <= 0d0) then call s_mpi_abort('Unsupported value of '// & - 'fluid_pp('//trim(iStr)//')%'// & - 'gamma. Exiting ...') + 'fluid_pp('//trim(iStr)//')%'// & + 'gamma. Exiting ...') elseif (model_eqns == 1 & .and. & fluid_pp(i)%gamma /= dflt_real) then call s_mpi_abort('Unsupported combination '// & - 'of values of model_eqns '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'gamma. Exiting ...') + 'of values of model_eqns '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'gamma. Exiting ...') elseif ((i <= num_fluids + bub_fac .and. fluid_pp(i)%gamma <= 0d0) & .or. & (i > num_fluids + bub_fac .and. fluid_pp(i)%gamma /= dflt_real)) & then call s_mpi_abort('Unsupported combination '// & - 'of values of num_fluids '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'gamma. Exiting ...') + 'of values of num_fluids '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'gamma. Exiting ...') elseif (fluid_pp(i)%pi_inf /= dflt_real & .and. & fluid_pp(i)%pi_inf < 0d0) then call s_mpi_abort('Unsupported value of '// & - 'fluid_pp('//trim(iStr)//')%'// & - 'pi_inf. Exiting ...') + 'fluid_pp('//trim(iStr)//')%'// & + 'pi_inf. Exiting ...') elseif (model_eqns == 1 & .and. & fluid_pp(i)%pi_inf /= dflt_real) then call s_mpi_abort('Unsupported combination '// & - 'of values of model_eqns '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'pi_inf. Exiting ...') + 'of values of model_eqns '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'pi_inf. Exiting ...') elseif ((i <= num_fluids + bub_fac .and. fluid_pp(i)%pi_inf < 0d0) & .or. & (i > num_fluids + bub_fac .and. fluid_pp(i)%pi_inf /= dflt_real)) & then call s_mpi_abort('Unsupported combination '// & - 'of values of num_fluids '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'pi_inf. Exiting ...') + 'of values of num_fluids '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'pi_inf. Exiting ...') end if end do ! Constraints on the format of the formatted database file(s) - if (format /= 1 .and. format /= 2) then + if (format /= 1 .and. format /= 2) then call s_mpi_abort('Unsupported choice for the value of format. '// & - 'Exiting ...') + 'Exiting ...') ! Constraints on the precision of the formatted database file(s) elseif (precision /= 1 .and. precision /= 2) then call s_mpi_abort('Unsupported choice for the value of '// & - 'precision. Exiting ...') + 'precision. Exiting ...') end if ! Constraints on the post-processing of the partial densities do i = 1, num_fluids - call s_int_to_str(i,iStr) + call s_int_to_str(i, iStr) if (((i > num_fluids .or. model_eqns == 1) & .and. & alpha_rho_wrt(i)) & @@ -261,52 +261,52 @@ subroutine s_check_inputs() .and. & alpha_rho_wrt(i))) then call s_mpi_abort('Unsupported choice of the '// & - 'combination of values for '// & - 'model_eqns, num_fluids and '// & - 'alpha_rho_wrt('//trim(iStr)//'). Exiting ...') + 'combination of values for '// & + 'model_eqns, num_fluids and '// & + 'alpha_rho_wrt('//trim(iStr)//'). Exiting ...') end if end do ! Constraints on the post-processing of the momentum if (n == 0 .and. mom_wrt(2)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and mom_wrt(2). Exiting ...') + 'values for n and mom_wrt(2). Exiting ...') elseif (n == 0 .and. mom_wrt(3)) then call s_mpi_abort('Unsupported cohice of the combination of '// & - 'values for n and mom_wrt(3). Exiting ...') + 'values for n and mom_wrt(3). Exiting ...') elseif (p == 0 .and. mom_wrt(3)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p and mom_wrt(3). Exiting ...') + 'values for p and mom_wrt(3). Exiting ...') ! Constraints on the post-processing of the velocity elseif (n == 0 .and. vel_wrt(2)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and vel_wrt(2). Exiting ...') + 'values for n and vel_wrt(2). Exiting ...') elseif (n == 0 .and. vel_wrt(3)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and vel_wrt(3). Exiting ...') + 'values for n and vel_wrt(3). Exiting ...') elseif (p == 0 .and. vel_wrt(3)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p and vel_wrt(3). Exiting ...') + 'values for p and vel_wrt(3). Exiting ...') end if ! Constraints on the post-processing of the flux limiter function if (n == 0 .and. flux_wrt(2)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and flux_wrt(2). Exiting ...') + 'values for n and flux_wrt(2). Exiting ...') elseif (n == 0 .and. flux_wrt(3)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and flux_wrt(3). Exiting ...') + 'values for n and flux_wrt(3). Exiting ...') elseif (p == 0 .and. flux_wrt(3)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p and flux_wrt(3). Exiting ...') + 'values for p and flux_wrt(3). Exiting ...') elseif (all(flux_lim /= (/dflt_int, 1, 2, 3, 4, 5, 6, 7/))) then call s_mpi_abort('Unsupported value of flux_lim. Exiting ...') end if ! Constraints on the post-processing of the volume fractions do i = 1, num_fluids - call s_int_to_str(i,iStr) + call s_int_to_str(i, iStr) if (((i > num_fluids .or. model_eqns == 1) & .and. & alpha_wrt(i)) & @@ -315,33 +315,33 @@ subroutine s_check_inputs() .and. & alpha_wrt(i))) then call s_mpi_abort('Unsupported choice of the '// & - 'combination of values for '// & - 'model_eqns, num_fluids and '// & - 'alpha_wrt('//trim(iStr)//'). Exiting ...') + 'combination of values for '// & + 'model_eqns, num_fluids and '// & + 'alpha_wrt('//trim(iStr)//'). Exiting ...') end if end do ! Constraints on the post-processing of the vorticity if (n == 0 .and. omega_wrt(1)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and omega_wrt(1). Exiting ...') + 'values for n and omega_wrt(1). Exiting ...') elseif (n == 0 .and. omega_wrt(2)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and omega_wrt(2). Exiting ...') + 'values for n and omega_wrt(2). Exiting ...') elseif (n == 0 .and. omega_wrt(3)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and omega_wrt(3). Exiting ...') + 'values for n and omega_wrt(3). Exiting ...') elseif (p == 0 .and. omega_wrt(1)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p and omega_wrt(1). Exiting ...') + 'values for p and omega_wrt(1). Exiting ...') elseif (p == 0 .and. omega_wrt(2)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p and omega_wrt(2). Exiting ...') + 'values for p and omega_wrt(2). Exiting ...') ! Constraints on post-processing of numerical Schlieren function elseif (n == 0 .and. schlieren_wrt) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and schlieren_wrt. Exiting ...') + 'values for n and schlieren_wrt. Exiting ...') ! Constraints on post-processing combination of flow variables elseif ((any(alpha_rho_wrt) .neqv. .true.) & @@ -363,17 +363,17 @@ subroutine s_check_inputs() .and. & (any(omega_wrt) .neqv. .true.)) then call s_mpi_abort('None of the flow variables have been '// & - 'selected for post-process. Exiting ...') + 'selected for post-process. Exiting ...') end if ! Constraints on the coefficients of numerical Schlieren function do i = 1, num_fluids - call s_int_to_str(i,iStr) + call s_int_to_str(i, iStr) if (schlieren_alpha(i) /= dflt_real & .and. & schlieren_alpha(i) <= 0d0) then call s_mpi_abort('Unsupported choice for the value of '// & - 'schlieren_alpha('//trim(iStr)//'). Exiting ...') + 'schlieren_alpha('//trim(iStr)//'). Exiting ...') elseif (((i > num_fluids .or. (schlieren_wrt .neqv. .true.)) & .and. & schlieren_alpha(i) /= dflt_real) & @@ -382,9 +382,9 @@ subroutine s_check_inputs() .and. & schlieren_alpha(i) <= 0d0)) then call s_mpi_abort('Unsupported choice of the '// & - 'combination of values for '// & - 'num_fluids, schlieren_wrt and '// & - 'schlieren_alpha('//trim(iStr)//'). Exiting ...') + 'combination of values for '// & + 'num_fluids, schlieren_wrt and '// & + 'schlieren_alpha('//trim(iStr)//'). Exiting ...') end if end do @@ -393,15 +393,15 @@ subroutine s_check_inputs() .and. & fd_order /= 1 .and. fd_order /= 2 .and. fd_order /= 4) then call s_mpi_abort('Unsupported choice for the value of '// & - 'fd_order. Exiting ...') + 'fd_order. Exiting ...') elseif ((any(omega_wrt) .or. schlieren_wrt) & .and. & fd_order == dflt_int) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for omega_wrt, schlieren_wrt and '// & - 'fd_order. Exiting ...') + 'values for omega_wrt, schlieren_wrt and '// & + 'fd_order. Exiting ...') end if end subroutine s_check_inputs -end module m_checker +end module m_checker diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index 1fcc087d9..ade96cd27 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -95,7 +95,7 @@ subroutine s_read_serial_data_files(t_step) ! ----------------------------- ! If the time-step directory is missing, the post-process exits. if (dir_check .neqv. .true.) then call s_mpi_abort('Time-step folder '//trim(t_step_dir)// & - ' is missing. Exiting ...') + ' is missing. Exiting ...') end if ! Reading the Grid Data File for the x-direction =================== @@ -112,7 +112,7 @@ subroutine s_read_serial_data_files(t_step) ! ----------------------------- close (1) else call s_mpi_abort('File x_cb.dat is missing in '// & - trim(t_step_dir)//'. Exiting ...') + trim(t_step_dir)//'. Exiting ...') end if ! Computing the cell-width distribution @@ -139,7 +139,7 @@ subroutine s_read_serial_data_files(t_step) ! ----------------------------- close (1) else call s_mpi_abort('File y_cb.dat is missing in '// & - trim(t_step_dir)//'. Exiting ...') + trim(t_step_dir)//'. Exiting ...') end if ! Computing the cell-width distribution @@ -166,7 +166,7 @@ subroutine s_read_serial_data_files(t_step) ! ----------------------------- close (1) else call s_mpi_abort('File z_cb.dat is missing in '// & - trim(t_step_dir)//'. Exiting ...') + trim(t_step_dir)//'. Exiting ...') end if ! Computing the cell-width distribution @@ -199,8 +199,8 @@ subroutine s_read_serial_data_files(t_step) ! ----------------------------- close (1) else call s_mpi_abort('File q_cons_vf'//trim(file_num)// & - '.dat is missing in '//trim(t_step_dir)// & - '. Exiting ...') + '.dat is missing in '//trim(t_step_dir)// & + '. Exiting ...') end if end do @@ -234,7 +234,7 @@ subroutine s_read_parallel_data_files(t_step) ! --------------------------- character(LEN=path_len + 2*name_len) :: file_loc logical :: file_exist - character(len = 10) :: t_step_string + character(len=10) :: t_step_string integer :: i @@ -294,7 +294,7 @@ subroutine s_read_parallel_data_files(t_step) ! --------------------------- call MPI_FILE_READ(ifile, z_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort( 'File '//trim(file_loc)//' is missing. Exiting...') + call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting...') end if ! Assigning local cell boundary locations @@ -337,14 +337,14 @@ subroutine s_read_parallel_data_files(t_step) ! --------------------------- var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + MPI_DOUBLE_PRECISION, status, ierr) end do else do i = 1, adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + MPI_DOUBLE_PRECISION, status, ierr) end do end if @@ -387,9 +387,9 @@ subroutine s_read_parallel_data_files(t_step) ! --------------------------- disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + MPI_DOUBLE_PRECISION, status, ierr) end do else do i = 1, adv_idx%end @@ -399,9 +399,9 @@ subroutine s_read_parallel_data_files(t_step) ! --------------------------- disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + MPI_DOUBLE_PRECISION, status, ierr) end do end if diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index f348c7799..7f3d7d9bd 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -122,19 +122,19 @@ contains -offset_y%beg:n + offset_y%end, & -offset_z%beg:p + offset_z%end)) if (grid_geometry == 3) then - allocate (cyl_q_sf(-offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end, & - -offset_x%beg:m + offset_x%end)) + allocate (cyl_q_sf(-offset_y%beg:n + offset_y%end, & + -offset_z%beg:p + offset_z%end, & + -offset_x%beg:m + offset_x%end)) end if if (precision == 1) then allocate (q_sf_s(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end)) + -offset_y%beg:n + offset_y%end, & + -offset_z%beg:p + offset_z%end)) if (grid_geometry == 3) then allocate (cyl_q_sf_s(-offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end, & - -offset_x%beg:m + offset_x%end)) + -offset_z%beg:p + offset_z%end, & + -offset_x%beg:m + offset_x%end)) end if end if @@ -183,22 +183,22 @@ contains lo_offset = (/offset_x%beg, offset_y%beg, offset_z%beg/) hi_offset = (/offset_x%end, offset_y%end, offset_z%end/) end if - + if (grid_geometry == 3) then dims = (/n + offset_y%beg + offset_y%end + 2, & - p + offset_z%beg + offset_z%end + 2, & - m + offset_x%beg + offset_x%end + 2/) + p + offset_z%beg + offset_z%end + 2, & + m + offset_x%beg + offset_x%end + 2/) else dims = (/m + offset_x%beg + offset_x%end + 2, & - n + offset_y%beg + offset_y%end + 2, & - p + offset_z%beg + offset_z%end + 2/) + n + offset_y%beg + offset_y%end + 2, & + p + offset_z%beg + offset_z%end + 2/) end if else lo_offset = (/offset_x%beg, offset_y%beg/) hi_offset = (/offset_x%end, offset_y%end/) dims = (/m + offset_x%beg + offset_x%end + 2, & - n + offset_y%beg + offset_y%end + 2/) + n + offset_y%beg + offset_y%end + 2/) end if end if @@ -450,8 +450,8 @@ contains ! is not the case, the post-process exits. if (dbfile == -1) then call s_mpi_abort('Unable to create Silo-HDF5 database '// & - 'slave file '//trim(file_loc)//'. '// & - 'Exiting ...') + 'slave file '//trim(file_loc)//'. '// & + 'Exiting ...') end if ! Next, analogous steps to the ones above are carried out by the @@ -468,8 +468,8 @@ contains if (dbroot == -1) then call s_mpi_abort('Unable to create Silo-HDF5 database '// & - 'master file '//trim(file_loc)//'. '// & - 'Exiting ...') + 'master file '//trim(file_loc)//'. '// & + 'Exiting ...') end if end if @@ -493,9 +493,9 @@ contains ! Verifying that the creation and setup process of the formatted ! database slave file has been performed without errors. If this ! is not the case, the post-process exits. - if (err /= 0) then + if (err /= 0) then call s_mpi_abort('Unable to create Binary database slave '// & - 'file '//trim(file_loc)//'. Exiting ...') + 'file '//trim(file_loc)//'. Exiting ...') end if ! Further defining the structure of the formatted database slave @@ -515,10 +515,10 @@ contains open (dbroot, IOSTAT=err, FILE=trim(file_loc), & FORM='unformatted', STATUS='replace') - if (err /= 0) then + if (err /= 0) then call s_mpi_abort('Unable to create Binary database '// & - 'master file '//trim(file_loc)// & - '. Exiting ...') + 'master file '//trim(file_loc)// & + '. Exiting ...') end if write (dbroot) m_root, 0, 0, dbvars @@ -624,52 +624,52 @@ contains if (precision == 1) then if (p > 0) then - do i = -1-offset_z%beg,p + offset_z%end - z_cb_s(i) = real(z_cb(i)) + do i = -1 - offset_z%beg, p + offset_z%end + z_cb_s(i) = real(z_cb(i)) end do else - do i = -1-offset_x%beg,m + offset_x%end - x_cb_s(i) = real(x_cb(i)) + do i = -1 - offset_x%beg, m + offset_x%end + x_cb_s(i) = real(x_cb(i)) end do - do i = -1-offset_y%beg,n + offset_y%end - y_cb_s(i) = real(y_cb(i)) + do i = -1 - offset_y%beg, n + offset_y%end + y_cb_s(i) = real(y_cb(i)) end do end if end if #:for PRECISION, SFX, DBT in [(1,'_s','DB_FLOAT'),(2,'',"DB_DOUBLE")] - if (precision == ${PRECISION}$) then - if (p > 0) then - err = DBMKOPTLIST(2, optlist) - err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) - err = DBADDIOPT(optlist, DBOPT_HI_OFFSET, hi_offset) - if (grid_geometry == 3) then - err = DBPUTQM(dbfile, 'rectilinear_grid', 16, & - 'x', 1, 'y', 1, 'z', 1, & - y_cb${SFX}$, z_cb${SFX}$, x_cb${SFX}$, dims, 3, & - ${DBT}$, DB_COLLINEAR, & - optlist, ierr) + if (precision == ${PRECISION}$) then + if (p > 0) then + err = DBMKOPTLIST(2, optlist) + err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) + err = DBADDIOPT(optlist, DBOPT_HI_OFFSET, hi_offset) + if (grid_geometry == 3) then + err = DBPUTQM(dbfile, 'rectilinear_grid', 16, & + 'x', 1, 'y', 1, 'z', 1, & + y_cb${SFX}$, z_cb${SFX}$, x_cb${SFX}$, dims, 3, & + ${DBT}$, DB_COLLINEAR, & + optlist, ierr) + else + err = DBPUTQM(dbfile, 'rectilinear_grid', 16, & + 'x', 1, 'y', 1, 'z', 1, & + x_cb${SFX}$, y_cb${SFX}$, z_cb${SFX}$, dims, 3, & + ${DBT}$, DB_COLLINEAR, & + optlist, ierr) + end if + err = DBFREEOPTLIST(optlist) else + err = DBMKOPTLIST(2, optlist) + err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) + err = DBADDIOPT(optlist, DBOPT_HI_OFFSET, hi_offset) err = DBPUTQM(dbfile, 'rectilinear_grid', 16, & - 'x', 1, 'y', 1, 'z', 1, & - x_cb${SFX}$, y_cb${SFX}$, z_cb${SFX}$, dims, 3, & - ${DBT}$, DB_COLLINEAR, & - optlist, ierr) + 'x', 1, 'y', 1, 'z', 1, & + x_cb${SFX}$, y_cb${SFX}$, DB_F77NULL, dims, 2, & + ${DBT}$, DB_COLLINEAR, & + optlist, ierr) + err = DBFREEOPTLIST(optlist) end if - err = DBFREEOPTLIST(optlist) - else - err = DBMKOPTLIST(2, optlist) - err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) - err = DBADDIOPT(optlist, DBOPT_HI_OFFSET, hi_offset) - err = DBPUTQM(dbfile, 'rectilinear_grid', 16, & - 'x', 1, 'y', 1, 'z', 1, & - x_cb${SFX}$, y_cb${SFX}$, DB_F77NULL, dims, 2, & - ${DBT}$, DB_COLLINEAR, & - optlist, ierr) - err = DBFREEOPTLIST(optlist) end if - end if #:endfor ! END: Silo-HDF5 Database Format =================================== @@ -851,7 +851,7 @@ contains do i = -offset_x%beg, m + offset_x%end do j = -offset_y%beg, n + offset_y%end do k = -offset_z%beg, p + offset_z%end - q_sf_s(i,j,k) = real(q_sf(i, j, k)) + q_sf_s(i, j, k) = real(q_sf(i, j, k)) end do end do end do @@ -868,32 +868,32 @@ contains end if #:for PRECISION, SFX, DBT in [(1,'_s','DB_FLOAT'),(2,'',"DB_DOUBLE")] - if (precision == ${PRECISION}$) then - if (p > 0) then - if (grid_geometry == 3) then - err = DBPUTQV1(dbfile, trim(varname), & - len_trim(varname), & - 'rectilinear_grid', 16, & - cyl_q_sf${SFX}$, dims - 1, 3, DB_F77NULL, & - 0, ${DBT}$, DB_ZONECENT, & - DB_F77NULL, ierr) + if (precision == ${PRECISION}$) then + if (p > 0) then + if (grid_geometry == 3) then + err = DBPUTQV1(dbfile, trim(varname), & + len_trim(varname), & + 'rectilinear_grid', 16, & + cyl_q_sf${SFX}$, dims - 1, 3, DB_F77NULL, & + 0, ${DBT}$, DB_ZONECENT, & + DB_F77NULL, ierr) + else + err = DBPUTQV1(dbfile, trim(varname), & + len_trim(varname), & + 'rectilinear_grid', 16, & + q_sf${SFX}$, dims - 1, 3, DB_F77NULL, & + 0, ${DBT}$, DB_ZONECENT, & + DB_F77NULL, ierr) + end if else err = DBPUTQV1(dbfile, trim(varname), & - len_trim(varname), & - 'rectilinear_grid', 16, & - q_sf${SFX}$, dims - 1, 3, DB_F77NULL, & - 0, ${DBT}$, DB_ZONECENT, & - DB_F77NULL, ierr) + len_trim(varname), & + 'rectilinear_grid', 16, & + q_sf${SFX}$, dims - 1, 2, DB_F77NULL, & + 0, ${DBT}$, DB_ZONECENT, & + DB_F77NULL, ierr) end if - else - err = DBPUTQV1(dbfile, trim(varname), & - len_trim(varname), & - 'rectilinear_grid', 16, & - q_sf${SFX}$, dims - 1, 2, DB_F77NULL, & - 0, ${DBT}$, DB_ZONECENT, & - DB_F77NULL, ierr) end if - end if #:endfor end if diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index d99b2c76c..1c690ad37 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -321,7 +321,6 @@ contains end do end subroutine s_derive_flux_limiter ! --------------------------------- - !> Computes the solution to the linear system Ax=b w/ sol = x !! @param A Input matrix !! @param b right-hand-side @@ -476,12 +475,12 @@ contains end subroutine s_derive_vorticity_component ! -------------------------- !> This subroutine gets as inputs the primitive variables. From those - !! inputs, it proceeds to calculate the value of the Q_M + !! inputs, it proceeds to calculate the value of the Q_M !! function, which are subsequently stored in the derived flow !! quantity storage variable, q_sf. !! @param q_prim_vf Primitive variables !! @param q_sf Q_M - subroutine s_derive_qm(q_prim_vf,q_sf) + subroutine s_derive_qm(q_prim_vf, q_sf) type(scalar_field), & dimension(sys_size), & intent(IN) :: q_prim_vf @@ -504,60 +503,60 @@ contains ! Get velocity gradient tensor q_jacobian_sf(:, :) = 0d0 - + do r = -fd_number, fd_number do jj = 1, 3 ! d()/dx q_jacobian_sf(jj, 1) = & - q_jacobian_sf(jj, 1)+ & + q_jacobian_sf(jj, 1) + & fd_coeff_x(r, j)* & - q_prim_vf(mom_idx%beg+jj-1)%sf(r + j, k, l) + q_prim_vf(mom_idx%beg + jj - 1)%sf(r + j, k, l) ! d()/dy q_jacobian_sf(jj, 2) = & - q_jacobian_sf(jj, 2)+ & + q_jacobian_sf(jj, 2) + & fd_coeff_y(r, k)* & - q_prim_vf(mom_idx%beg+jj-1)%sf(j, r + k, l) + q_prim_vf(mom_idx%beg + jj - 1)%sf(j, r + k, l) ! d()/dz q_jacobian_sf(jj, 3) = & - q_jacobian_sf(jj, 3)+ & + q_jacobian_sf(jj, 3) + & fd_coeff_z(r, l)* & - q_prim_vf(mom_idx%beg+jj-1)%sf(j, k, r + l) + q_prim_vf(mom_idx%beg + jj - 1)%sf(j, k, r + l) end do end do - + ! Decompose J into asymmetric matrix, S, and a skew-symmetric matrix, O do jj = 1, 3 do kk = 1, 3 - S(jj, kk) = 0.5D0* & - (q_jacobian_sf(jj, kk) + q_jacobian_sf(kk, jj)) - O(jj, kk) = 0.5D0* & - (q_jacobian_sf(jj, kk) - q_jacobian_sf(kk, jj)) + S(jj, kk) = 0.5d0* & + (q_jacobian_sf(jj, kk) + q_jacobian_sf(kk, jj)) + O(jj, kk) = 0.5d0* & + (q_jacobian_sf(jj, kk) - q_jacobian_sf(kk, jj)) end do end do - + ! Compute S2 = S*S' do jj = 1, 3 do kk = 1, 3 - O2(jj, kk) = O(jj,1)*O(kk,1)+ & - O(jj,2)*O(kk,2)+ & - O(jj,3)*O(kk,3) - S2(jj, kk) = S(jj,1)*S(kk,1)+ & - S(jj,2)*S(kk,2)+ & - S(jj,3)*S(kk,3) + O2(jj, kk) = O(jj, 1)*O(kk, 1) + & + O(jj, 2)*O(kk, 2) + & + O(jj, 3)*O(kk, 3) + S2(jj, kk) = S(jj, 1)*S(kk, 1) + & + S(jj, 2)*S(kk, 2) + & + S(jj, 3)*S(kk, 3) end do end do - + ! Compute Q - Q = 0.5*((O2(1,1)+O2(2,2)+O2(3,3))- & - (S2(1,1)+S2(2,2)+S2(3,3))) - trS = S(1,1)+S(2,2)+S(3,3) - IIS = 0.5*((S(1,1)+S(2,2)+S(3,3))**2- & - (S2(1,1)+S2(2,2)+S2(3,3))) - q_sf(j, k, l) = Q+IIS + Q = 0.5*((O2(1, 1) + O2(2, 2) + O2(3, 3)) - & + (S2(1, 1) + S2(2, 2) + S2(3, 3))) + trS = S(1, 1) + S(2, 2) + S(3, 3) + IIS = 0.5*((S(1, 1) + S(2, 2) + S(3, 3))**2 - & + (S2(1, 1) + S2(2, 2) + S2(3, 3))) + q_sf(j, k, l) = Q + IIS end do end do - end do + end do end subroutine s_derive_qm diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index ad1bfa1b1..d514663b5 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -222,15 +222,14 @@ module m_global_parameters logical :: polytropic logical :: polydisperse integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer - real(kind(0d0)) :: R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, G, pv, M_n, M_v + real(kind(0d0)) :: R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, G, pv, M_n, M_v real(kind(0d0)), dimension(:), allocatable :: k_n, k_v, pb0, mass_n0, mass_v0, Pe_T real(kind(0d0)), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN real(kind(0d0)) :: mul0, ss, gamma_v, mu_v real(kind(0d0)) :: gamma_m, gamma_n, mu_n real(kind(0d0)) :: poly_sigma - real(kind(0d0)) :: sigR - integer :: nmom - + real(kind(0d0)) :: sigR + integer :: nmom !> @} @@ -389,8 +388,8 @@ contains alf_idx = 1 end if - if(qbmm) then - nmom = 6 + if (qbmm) then + nmom = 6 end if if (bubbles) then @@ -407,14 +406,12 @@ contains end if sys_size = bub_idx%end - - allocate (bub_idx%rs(nb), bub_idx%vs(nb)) allocate (bub_idx%ps(nb), bub_idx%ms(nb)) allocate (weight(nb), R0(nb), V0(nb)) - if(qbmm) then - allocate(bub_idx%moms(nb, nmom)) + if (qbmm) then + allocate (bub_idx%moms(nb, nmom)) do i = 1, nb do j = 1, nmom bub_idx%moms(i, j) = bub_idx%beg + (j - 1) + (i - 1)*nmom @@ -423,7 +420,7 @@ contains bub_idx%vs(i) = bub_idx%moms(i, 3) end do else - do i = 1, nb + do i = 1, nb if (polytropic .neqv. .true.) then fac = 4 else @@ -440,8 +437,6 @@ contains end do end if - - if (nb == 1) then weight(:) = 1d0 R0(:) = 1d0 @@ -460,7 +455,6 @@ contains pref = 1.d0 end if - end if if (hypoelasticity) then @@ -539,7 +533,7 @@ contains stop 'Invalid value of nb' end if - if (polytropic ) then + if (polytropic) then rhoref = 1.d0 pref = 1.d0 end if @@ -562,7 +556,7 @@ contains #ifdef MFC_MPI allocate (MPI_IO_DATA%view(1:sys_size)) - allocate (MPI_IO_DATA%var(1:sys_size)) + allocate (MPI_IO_DATA%var(1:sys_size)) do i = 1, sys_size allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) @@ -606,15 +600,15 @@ contains end if ! Allocating single precision grid variables if needed - if (precision == 1) then - allocate (x_cb_s(-1 - offset_x%beg:m + offset_x%end)) - if (n > 0) then - allocate (y_cb_s(-1 - offset_x%beg:n + offset_x%end)) - if (p > 0) then - allocate (z_cb_s(-1 - offset_x%beg:m + offset_x%end)) - end if - end if - end if + if (precision == 1) then + allocate (x_cb_s(-1 - offset_x%beg:m + offset_x%end)) + if (n > 0) then + allocate (y_cb_s(-1 - offset_x%beg:n + offset_x%end)) + if (p > 0) then + allocate (z_cb_s(-1 - offset_x%beg:m + offset_x%end)) + end if + end if + end if ! Allocating the grid variables in the x-coordinate direction allocate (x_cb(-1 - offset_x%beg:m + offset_x%end)) @@ -726,5 +720,4 @@ contains end subroutine s_finalize_global_parameters_module ! ----------------- - end module m_global_parameters diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index 8250fb47d..c0886a474 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -48,7 +48,6 @@ module m_mpi_proxy contains - !> Computation of parameters, allocation procedures, and/or !! any other tasks needed to properly setup the module subroutine s_initialize_mpi_proxy_module() ! ------------------------------ @@ -165,8 +164,8 @@ contains #:for VAR in [ 'cyl_coord', 'adv_alphan', 'mpp_lim', 'mixture_err', & & 'alt_soundspeed', 'hypoelasticity', 'parallel_io', 'rho_wrt', & - & 'E_wrt', 'pres_wrt', 'gamma_wrt', & - & 'heat_ratio_wrt', 'pi_inf_wrt', 'pres_inf_wrt', 'cons_vars_wrt', & + & 'E_wrt', 'pres_wrt', 'gamma_wrt', & + & 'heat_ratio_wrt', 'pi_inf_wrt', 'pres_inf_wrt', 'cons_vars_wrt', & & 'prim_vars_wrt', 'c_wrt', 'qm_wrt','schlieren_wrt', 'bubbles', & & 'polytropic', 'polydisperse', 'file_per_process', 'relax' ] call MPI_BCAST(${VAR}$, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) @@ -612,7 +611,7 @@ contains else offset_x%beg = 0 end if - + ! Boundary condition at the end if (proc_coords(1) < num_procs_x - 1 .or. bc_x%end == -1) then proc_coords(1) = proc_coords(1) + 1 @@ -933,13 +932,13 @@ contains r = sys_size*(j + buff_size) & + sys_size*buff_size*k + (i - 1) & + sys_size*buff_size*(n + 1)*l - q_cons_vf(i)%sf(j, k, l) = q_cons_buffer_in(r) + q_cons_vf(i)%sf(j, k, l) = q_cons_buffer_in(r) #if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then print *, "Error", j, k, l, i error stop "NaN(s) in recv" end if -#endif +#endif end do end do end do @@ -1013,13 +1012,13 @@ contains r = (i - 1) + sys_size*(j - m - 1) & + sys_size*buff_size*k & + sys_size*buff_size*(n + 1)*l - q_cons_vf(i)%sf(j, k, l) = q_cons_buffer_in(r) + q_cons_vf(i)%sf(j, k, l) = q_cons_buffer_in(r) #if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then print *, "Error", j, k, l, i error stop "NaN(s) in recv" end if -#endif +#endif end do end do end do @@ -1109,11 +1108,11 @@ contains (m + 2*buff_size + 1)*buff_size*l q_cons_vf(i)%sf(j, k, l) = q_cons_buffer_in(r) #if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then print *, "Error", j, k, l, i error stop "NaN(s) in recv" end if -#endif +#endif end do end do end do @@ -1195,11 +1194,11 @@ contains (m + 2*buff_size + 1)*buff_size*l q_cons_vf(i)%sf(j, k, l) = q_cons_buffer_in(r) #if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then print *, "Error", j, k, l, i error stop "NaN(s) in recv" end if -#endif +#endif end do end do end do @@ -1294,11 +1293,11 @@ contains (n + 2*buff_size + 1)*(l + buff_size) q_cons_vf(i)%sf(j, k, l) = q_cons_buffer_in(r) #if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then print *, "Error", j, k, l, i error stop "NaN(s) in recv" end if -#endif +#endif end do end do end do @@ -1385,11 +1384,11 @@ contains (n + 2*buff_size + 1)*(l - p - 1) q_cons_vf(i)%sf(j, k, l) = q_cons_buffer_in(r) #if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then print *, "Error", j, k, l, i error stop "NaN(s) in recv" end if -#endif +#endif end do end do end do @@ -1405,7 +1404,6 @@ contains end subroutine s_mpi_sendrecv_cons_vars_buffer_regions ! --------------- - !> This subroutine gathers the Silo database metadata for !! the spatial extents in order to boost the performance of !! the multidimensional visualization. @@ -1642,5 +1640,4 @@ contains end subroutine s_finalize_mpi_proxy_module ! ------------------------- - end module m_mpi_proxy diff --git a/src/post_process/m_start_up.f90 b/src/post_process/m_start_up.f90 index 4d5e07e18..c5c093cdf 100644 --- a/src/post_process/m_start_up.f90 +++ b/src/post_process/m_start_up.f90 @@ -3,8 +3,8 @@ !! @brief Contains module m_start_up !> @brief This module contains the subroutines that read in and check the -!! consistency of the user provided inputs. This module also allocates, initializes and -!! deallocates the relevant variables and sets up the time stepping, +!! consistency of the user provided inputs. This module also allocates, initializes and +!! deallocates the relevant variables and sets up the time stepping, !! MPI decomposition and I/O procedures module m_start_up @@ -18,7 +18,7 @@ module m_start_up use m_variables_conversion !< Subroutines to change the state variables from !! one form to another - + use m_data_input !< Procedures reading raw simulation data to fill !! the conservative, primitive and grid variables @@ -86,11 +86,11 @@ subroutine s_read_input_file() ! --------------------------------------- read (1, NML=user_inputs, iostat=iostatus) if (iostatus /= 0) then - backspace(1) - read(1,fmt='(A)') line - print*, 'Invalid line in namelist: '//trim(line) + backspace (1) + read (1, fmt='(A)') line + print *, 'Invalid line in namelist: '//trim(line) call s_mpi_abort('Invalid line in pre_process.inp. It is '// & - 'likely due to a datatype mismatch. Exiting ...') + 'likely due to a datatype mismatch. Exiting ...') end if close (1) @@ -126,7 +126,7 @@ subroutine s_check_input_file() ! -------------------------------------- ! Constraint on the location of the case directory if (dir_check .neqv. .true.) then call s_mpi_abort('Unsupported choice for the value of '// & - 'case_dir. Exiting ...') + 'case_dir. Exiting ...') end if call s_check_inputs() @@ -134,14 +134,14 @@ subroutine s_check_input_file() ! -------------------------------------- end subroutine s_check_input_file ! ------------------------------------ subroutine s_perform_time_step(t_step) - - integer, intent(INOUT) :: t_step + + integer, intent(INOUT) :: t_step if (proc_rank == 0) then - print '(" ["I3"%] Saving "I8" of "I0" @ t_step = "I0"")', & - int(ceiling(100d0*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), & - (t_step - t_step_start)/t_step_save + 1, & - (t_step_stop - t_step_start)/t_step_save + 1, & - t_step + print '(" ["I3"%] Saving "I8" of "I0" @ t_step = "I0"")', & + int(ceiling(100d0*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), & + (t_step - t_step_start)/t_step_save + 1, & + (t_step_stop - t_step_start)/t_step_save + 1, & + t_step end if ! Populating the grid and conservative variables @@ -162,10 +162,10 @@ end subroutine s_perform_time_step subroutine s_save_data(t_step, varname, pres, c, H) - integer, intent(INOUT) :: t_step + integer, intent(INOUT) :: t_step character(LEN=name_len), intent(INOUT) :: varname real(kind(0d0)), intent(INOUT) :: pres, c, H - + integer :: i, j, k, l ! Opening a new formatted database file @@ -444,11 +444,11 @@ subroutine s_save_data(t_step, varname, pres, c, H) pres = q_prim_vf(E_idx)%sf(i, j, k) H = ((gamma_sf(i, j, k) + 1d0)*pres + & - pi_inf_sf(i, j, k))/rho_sf(i, j, k) + pi_inf_sf(i, j, k))/rho_sf(i, j, k) call s_compute_speed_of_sound(pres, rho_sf(i, j, k), & - gamma_sf(i, j, k), pi_inf_sf(i, j, k), & - H, adv, 0d0, c) + gamma_sf(i, j, k), pi_inf_sf(i, j, k), & + H, adv, 0d0, c) q_sf(i, j, k) = c end do @@ -579,16 +579,16 @@ subroutine s_save_data(t_step, varname, pres, c, H) ! Closing the formatted database file call s_close_formatted_database_file() - end subroutine s_save_data + end subroutine s_save_data subroutine s_initialize_modules() ! Computation of parameters, allocation procedures, and/or any other tasks ! needed to properly setup the modules call s_initialize_global_parameters_module() - if(bubbles .and. nb > 1) then + if (bubbles .and. nb > 1) then call s_simpson end if - if(bubbles .and. .not. polytropic) then + if (bubbles .and. .not. polytropic) then call s_initialize_nonpoly() end if if (num_procs > 1) call s_initialize_mpi_proxy_module() @@ -617,7 +617,7 @@ subroutine s_initialize_mpi_domain() call s_assign_default_values_to_user_inputs() call s_read_input_file() call s_check_input_file() - + print '(" Post-processing a "I0"x"I0"x"I0" case on "I0" rank(s)")', m, n, p, num_procs end if @@ -630,7 +630,6 @@ subroutine s_initialize_mpi_domain() end subroutine s_initialize_mpi_domain - subroutine s_finalize_modules() ! Disassociate pointers for serial and parallel I/O s_read_data_files => null() diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index c2815d1aa..c780ce9ac 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -28,7 +28,7 @@ program p_main real(kind(0d0)) :: pres real(kind(0d0)) :: c - real(kind(0d0)) :: H + real(kind(0d0)) :: H call s_initialize_mpi_domain() diff --git a/src/pre_process/include/1dHardcodedIC.fpp b/src/pre_process/include/1dHardcodedIC.fpp index 81e491f06..01e9a4d56 100644 --- a/src/pre_process/include/1dHardcodedIC.fpp +++ b/src/pre_process/include/1dHardcodedIC.fpp @@ -1,17 +1,16 @@ #:def Hardcoded1DVariables() ! Place any declaration of intermediate variables here - #:enddef #:def Hardcoded1D() - select case(patch_icpp(patch_id)%hcid) - case(100) - ! Put your variable assignments here - case default - call s_int_to_str(patch_id, iStr) - call s_mpi_abort("Invalid hcid specified for patch " // trim(iStr)) + select case (patch_icpp(patch_id)%hcid) + case (100) + ! Put your variable assignments here + case default + call s_int_to_str(patch_id, iStr) + call s_mpi_abort("Invalid hcid specified for patch "//trim(iStr)) end select #:enddef diff --git a/src/pre_process/include/2dHardcodedIC.fpp b/src/pre_process/include/2dHardcodedIC.fpp index 7b432ddb6..a77973d3e 100644 --- a/src/pre_process/include/2dHardcodedIC.fpp +++ b/src/pre_process/include/2dHardcodedIC.fpp @@ -7,24 +7,24 @@ #:enddef #:def Hardcoded2D() - - select case(patch_icpp(patch_id)%hcid) ! 2D_hardcoded_ic example case - case(200) - if (y_cc(j) <= (-x_cc(i)**3 + 1)**(1d0/3d0)) then - ! Volume Fractions - q_prim_vf(advxb)%sf(i, j, 0) = eps - q_prim_vf(advxe)%sf(i, j, 0) = 1d0-eps - ! Denssities - q_prim_vf(contxb)%sf(i, j, 0) = eps*1000d0 - q_prim_vf(contxe)%sf(i, j, 0) = (1d0-eps)*1d0 - ! Pressure - q_prim_vf(E_idx)%sf(i, j, 0) = 1000d0 - end if - case default - if (proc_rank == 0) then - call s_int_to_str(patch_id, iStr) - call s_mpi_abort("Invalid hcid specified for patch " // trim(iStr)) - end if + + select case (patch_icpp(patch_id)%hcid) ! 2D_hardcoded_ic example case + case (200) + if (y_cc(j) <= (-x_cc(i)**3 + 1)**(1d0/3d0)) then + ! Volume Fractions + q_prim_vf(advxb)%sf(i, j, 0) = eps + q_prim_vf(advxe)%sf(i, j, 0) = 1d0 - eps + ! Denssities + q_prim_vf(contxb)%sf(i, j, 0) = eps*1000d0 + q_prim_vf(contxe)%sf(i, j, 0) = (1d0 - eps)*1d0 + ! Pressure + q_prim_vf(E_idx)%sf(i, j, 0) = 1000d0 + end if + case default + if (proc_rank == 0) then + call s_int_to_str(patch_id, iStr) + call s_mpi_abort("Invalid hcid specified for patch "//trim(iStr)) + end if end select #:enddef diff --git a/src/pre_process/include/3dHardcodedIC.fpp b/src/pre_process/include/3dHardcodedIC.fpp index 17e090e05..07878e30d 100644 --- a/src/pre_process/include/3dHardcodedIC.fpp +++ b/src/pre_process/include/3dHardcodedIC.fpp @@ -1,17 +1,16 @@ #:def Hardcoded3DVariables() ! Place any declaration of intermediate variables here - #:enddef #:def Hardcoded3D() - select case(patch_icpp(patch_id)%hcid) - case(300) - ! Put your variable assignments here - case default - call s_int_to_str(patch_id, iStr) - call s_mpi_abort("Invalid hcid specified for patch " // trim(iStr)) + select case (patch_icpp(patch_id)%hcid) + case (300) + ! Put your variable assignments here + case default + call s_int_to_str(patch_id, iStr) + call s_mpi_abort("Invalid hcid specified for patch "//trim(iStr)) end select #:enddef diff --git a/src/pre_process/m_assign_variables.f90 b/src/pre_process/m_assign_variables.f90 index c11f9fd4e..6efd890c7 100644 --- a/src/pre_process/m_assign_variables.f90 +++ b/src/pre_process/m_assign_variables.f90 @@ -19,7 +19,7 @@ module m_assign_variables type(scalar_field) :: alf_sum procedure(s_assign_patch_xxxxx_primitive_variables), & - pointer :: s_assign_patch_primitive_variables => null() !< + pointer :: s_assign_patch_primitive_variables => null() !< !! Depending on the multicomponent flow model, this variable is a pointer to !! either the subroutine s_assign_patch_mixture_primitive_variables, or the !! subroutine s_assign_patch_species_primitive_variables @@ -36,7 +36,7 @@ module m_assign_variables !! @param k (y,th) cell index in which the mixture or species primitive variables from the indicated patch areassigned !! @param l (z) cell index in which the mixture or species primitive variables from the indicated patch areassigned subroutine s_assign_patch_xxxxx_primitive_variables(patch_id, j, k, l, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) import :: scalar_field, sys_size, n, m, p @@ -51,10 +51,10 @@ end subroutine s_assign_patch_xxxxx_primitive_variables end interface private; public :: s_initialize_assign_variables_module, & - s_assign_patch_primitive_variables, & - s_assign_patch_mixture_primitive_variables, & - s_assign_patch_species_primitive_variables, & - s_finalize_assign_variables_module + s_assign_patch_primitive_variables, & + s_assign_patch_mixture_primitive_variables, & + s_assign_patch_species_primitive_variables, & + s_finalize_assign_variables_module contains @@ -73,7 +73,7 @@ subroutine s_initialize_assign_variables_module() s_assign_patch_primitive_variables => & s_assign_patch_species_primitive_variables end if - + end subroutine s_initialize_assign_variables_module !> This subroutine assigns the mixture primitive variables @@ -91,7 +91,7 @@ end subroutine s_initialize_assign_variables_module !! @param k the y-dir node index !! @param l the z-dir node index subroutine s_assign_patch_mixture_primitive_variables(patch_id, j, k, l, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) !$acc routine seq integer, intent(IN) :: patch_id @@ -126,9 +126,9 @@ subroutine s_assign_patch_mixture_primitive_variables(patch_id, j, k, l, & q_prim_vf(i + 1)%sf(j, k, l) = & 1d0/q_prim_vf(1)%sf(j, k, l)* & (eta*patch_icpp(patch_id)%rho & - *patch_icpp(patch_id)%vel(i) & - + (1d0 - eta)*patch_icpp(smooth_patch_id)%rho & - *patch_icpp(smooth_patch_id)%vel(i)) + *patch_icpp(patch_id)%vel(i) & + + (1d0 - eta)*patch_icpp(smooth_patch_id)%rho & + *patch_icpp(smooth_patch_id)%vel(i)) end do ! Specific heat ratio function @@ -140,9 +140,9 @@ subroutine s_assign_patch_mixture_primitive_variables(patch_id, j, k, l, & q_prim_vf(E_idx)%sf(j, k, l) = & 1d0/q_prim_vf(gamma_idx)%sf(j, k, l)* & (eta*patch_icpp(patch_id)%gamma & - *patch_icpp(patch_id)%pres & - + (1d0 - eta)*patch_icpp(smooth_patch_id)%gamma & - *patch_icpp(smooth_patch_id)%pres) + *patch_icpp(patch_id)%pres & + + (1d0 - eta)*patch_icpp(smooth_patch_id)%gamma & + *patch_icpp(smooth_patch_id)%pres) ! Liquid stiffness function q_prim_vf(pi_inf_idx)%sf(j, k, l) = & @@ -161,62 +161,60 @@ subroutine s_perturb_primitive(j, k, l, q_prim_vf) integer, intent(IN) :: j, k, l integer :: i - real(kind(0d0)) :: pres_mag , loc, n_tait, B_tait, p0 + real(kind(0d0)) :: pres_mag, loc, n_tait, B_tait, p0 real(kind(0d0)) :: R3bar, n0, ratio, nH, vfH, velH, rhoH, deno p0 = 101325 - pres_mag = 1D-1 + pres_mag = 1d-1 loc = x_cc(177) n_tait = fluid_pp(1)%gamma B_tait = fluid_pp(1)%pi_inf - n_tait = 1.d0/n_tait + 1.d0 - B_tait = B_tait * (n_tait - 1d0) / n_tait + n_tait = 1.d0/n_tait + 1.d0 + B_tait = B_tait*(n_tait - 1d0)/n_tait - if(j < 177) then - q_prim_vf(E_idx)%sf(j, k, l) = 0.5 * q_prim_vf(E_idx)%sf(j, k, l) + if (j < 177) then + q_prim_vf(E_idx)%sf(j, k, l) = 0.5*q_prim_vf(E_idx)%sf(j, k, l) end if - - if(qbmm) then + if (qbmm) then do i = 1, nb - q_prim_vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) = q_prim_vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) * ((p0 - fluid_pp(1)%pv) / (q_prim_vf(E_idx)%sf(j, k, l) * p0 - fluid_pp(1)%pv)) ** (1 / 3d0) + q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) = q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)*((p0 - fluid_pp(1)%pv)/(q_prim_vf(E_idx)%sf(j, k, l)*p0 - fluid_pp(1)%pv))**(1/3d0) end do end if - R3bar = 0d0 - if(qbmm) then + if (qbmm) then do i = 1, nb - R3bar = R3bar + weight(i) * 0.5d0 * (q_prim_vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) ) ** 3d0 - R3bar = R3bar + weight(i) * 0.5d0 * (q_prim_vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) ) ** 3d0 + R3bar = R3bar + weight(i)*0.5d0*(q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l))**3d0 + R3bar = R3bar + weight(i)*0.5d0*(q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l))**3d0 end do else do i = 1, nb - if(polytropic) then - R3bar = R3bar + weight(i) * (q_prim_vf(bubxb + (i - 1) * 2)%sf(j, k, l)) ** 3d0 + if (polytropic) then + R3bar = R3bar + weight(i)*(q_prim_vf(bubxb + (i - 1)*2)%sf(j, k, l))**3d0 else - R3bar = R3bar + weight(i) * (q_prim_vf(bubxb + (i - 1) * 4)%sf(j, k, l)) ** 3d0 + R3bar = R3bar + weight(i)*(q_prim_vf(bubxb + (i - 1)*4)%sf(j, k, l))**3d0 end if end do end if - n0 = 3d0 * q_prim_vf(alf_idx) % sf(j, k, l) / (4d0 * pi * R3bar) + n0 = 3d0*q_prim_vf(alf_idx)%sf(j, k, l)/(4d0*pi*R3bar) - ratio = ((1d0 + B_tait) / (q_prim_vf(E_idx)%sf(j, k, l) + B_tait)) ** (1D0 / n_tait) + ratio = ((1d0 + B_tait)/(q_prim_vf(E_idx)%sf(j, k, l) + B_tait))**(1d0/n_tait) - nH = n0 / ( (1d0 - q_prim_vf(alf_idx)%sf(j, k, l)) * ratio + (4d0 * pi / 3d0) * n0 * R3bar ) - vfH = (4d0 * pi / 3d0) * nH * R3bar - rhoH = (1d0 - vfH) / ratio - deno = 1d0 - (1d0 - q_prim_vf(alf_idx)%sf(j, k, l)) / rhoH + nH = n0/((1d0 - q_prim_vf(alf_idx)%sf(j, k, l))*ratio + (4d0*pi/3d0)*n0*R3bar) + vfH = (4d0*pi/3d0)*nH*R3bar + rhoH = (1d0 - vfH)/ratio + deno = 1d0 - (1d0 - q_prim_vf(alf_idx)%sf(j, k, l))/rhoH - if(deno == 0d0) then + if (deno == 0d0) then velH = 0d0 else - velH = (q_prim_vf(E_idx)%sf(j, k, l) - 1d0) / (1d0 - q_prim_vf(alf_idx)%sf(j, k, l)) / deno + velH = (q_prim_vf(E_idx)%sf(j, k, l) - 1d0)/(1d0 - q_prim_vf(alf_idx)%sf(j, k, l))/deno velH = dsqrt(velH) - velH = velH * deno + velH = velH*deno end if do i = cont_idx%beg, cont_idx%end @@ -239,7 +237,7 @@ end subroutine s_perturb_primitive !! @param k the y-dir node index !! @param l the z-dir node index subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) !$acc routine seq integer, intent(IN) :: patch_id @@ -328,7 +326,7 @@ subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, & q_prim_vf(i)%sf(j, k, l) = patch_icpp(patch_id)%alpha_rho(i) end do end if - + ! Density and the specific heat ratio and liquid stiffness functions ! call s_convert_species_to_mixture_variables( & call s_convert_to_mixture_variables( & @@ -336,7 +334,7 @@ subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, & patch_icpp(patch_id)%rho, & patch_icpp(patch_id)%gamma, & patch_icpp(patch_id)%pi_inf, & - patch_icpp(patch_id)%qv ) + patch_icpp(patch_id)%qv) ! ================================================================== @@ -407,7 +405,7 @@ subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, & patch_icpp(smooth_patch_id)%rho, & patch_icpp(smooth_patch_id)%gamma, & patch_icpp(smooth_patch_id)%pi_inf, & - patch_icpp(smooth_patch_id)%qv ) + patch_icpp(smooth_patch_id)%qv) ! ================================================================== @@ -468,7 +466,7 @@ subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, & ! Density and the specific heat ratio and liquid stiffness functions ! call s_convert_species_to_mixture_variables(q_prim_vf, j, k, l, & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, & - rho, gamma, pi_inf, qv) + rho, gamma, pi_inf, qv) ! Velocity do i = 1, E_idx - mom_idx%beg @@ -478,12 +476,12 @@ subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, & end do ! Set streamwise velocity to hypertangent function of y - if (vel_profile) then - q_prim_vf(1 + cont_idx%end)%sf(j, k, l) = & - (eta*patch_icpp(patch_id)%vel(1)*tanh(y_cc(k)) & + if (vel_profile) then + q_prim_vf(1 + cont_idx%end)%sf(j, k, l) = & + (eta*patch_icpp(patch_id)%vel(1)*tanh(y_cc(k)) & + (1d0 - eta)*orig_prim_vf(1 + cont_idx%end)) - end if - + end if + ! Set partial pressures to mixture pressure for the 6-eqn model if (model_eqns == 3) then do i = internalEnergies_idx%beg, internalEnergies_idx%end @@ -556,7 +554,7 @@ subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, & end if end do end if - + ! Updating the patch identities bookkeeping variable if (1d0 - eta < 1d-16) patch_id_fp(j, k, l) = patch_id diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index f2262d58d..1a26d8830 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -33,7 +33,7 @@ contains ! integer, intent(in) :: i - integer :: i + integer :: i do i = 1, num_patches_max if (i <= num_patches) then @@ -52,8 +52,8 @@ contains call s_check_ellipse_patch_geometry(i) elseif (patch_icpp(i)%geometry == 6) then call s_mpi_abort('Unimplemented choice of geometry 6'// & - ' (formerly "Vortex") of active patch '//trim(iStr)// & - ' detected. Exiting ...') + ' (formerly "Vortex") of active patch '//trim(iStr)// & + ' detected. Exiting ...') elseif (patch_icpp(i)%geometry == 7) then call s_check_2D_analytical_patch_geometry(i) elseif (patch_icpp(i)%geometry == 8) then @@ -86,21 +86,20 @@ contains call s_check_model_geometry(i) else call s_mpi_abort('Unsupported choice of the '// & - 'geometry of active patch '//trim(iStr)//& - ' detected. Exiting ...') + 'geometry of active patch '//trim(iStr)// & + ' detected. Exiting ...') end if else if (patch_icpp(i)%geometry == dflt_int) then call s_check_inactive_patch_geometry(i) else call s_mpi_abort('Unsupported choice of the '// & - 'geometry of inactive patch '//trim(iStr)//& - ' detected. Exiting ...') + 'geometry of inactive patch '//trim(iStr)// & + ' detected. Exiting ...') end if end if end do - ! Constraints on overwrite rights initial condition patch parameters do i = 1, num_patches if (i <= num_patches) then @@ -153,8 +152,8 @@ contains cyl_coord) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of line segment '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of line segment '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -175,10 +174,10 @@ contains patch_icpp(patch_id)%x_centroid == dflt_real & .or. & patch_icpp(patch_id)%y_centroid == dflt_real) then - + call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of circle '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of circle '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -205,8 +204,8 @@ contains patch_icpp(patch_id)%length_y <= 0d0) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of rectangle '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of rectangle '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -235,8 +234,8 @@ contains patch_icpp(patch_id)%normal(3) /= dflt_real) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of line sweep '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of line sweep '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -265,8 +264,8 @@ contains patch_icpp(patch_id)%radii(3) /= dflt_real) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of ellipse '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of ellipse '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -292,17 +291,16 @@ contains .or. & patch_icpp(patch_id)%length_y <= 0d0 & .or. & - patch_icpp(patch_id)%vel(2)<= 0d0) then + patch_icpp(patch_id)%vel(2) <= 0d0) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of Taylor Green '// & - 'vortex patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of Taylor Green '// & + 'vortex patch '//trim(iStr)//'. Exiting ...') end if end subroutine s_check_2D_TaylorGreen_vortex_patch_geometry! -------------- - !> This subroutine verifies that the geometric parameters of !! the analytical patch have consistently been inputted by !! the user. @@ -322,8 +320,8 @@ contains patch_icpp(patch_id)%length_x <= 0d0) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of 1D analytical '// & - 'patch '//trim(iStr)//'. Exiting...') + 'geometric parameters of 1D analytical '// & + 'patch '//trim(iStr)//'. Exiting...') end if end subroutine s_check_1D_analytical_patch_geometry ! --------------------- @@ -346,10 +344,10 @@ contains patch_icpp(patch_id)%length_x <= 0d0 & .or. & patch_icpp(patch_id)%length_y <= 0d0) then - + call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of 2D analytical '// & - 'patch '//trim(iStr)//'. Exiting...') + 'geometric parameters of 2D analytical '// & + 'patch '//trim(iStr)//'. Exiting...') end if end subroutine s_check_2D_analytical_patch_geometry ! --------------------- @@ -378,8 +376,8 @@ contains patch_icpp(patch_id)%length_z <= 0d0) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of 3D analytical '// & - 'patch '//trim(iStr)//'. Exiting...') + 'geometric parameters of 3D analytical '// & + 'patch '//trim(iStr)//'. Exiting...') end if end subroutine s_check_3D_analytical_patch_geometry ! --------------------- @@ -404,8 +402,8 @@ contains patch_icpp(patch_id)%z_centroid == dflt_real) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of sphere '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of sphere '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -438,8 +436,8 @@ contains patch_icpp(patch_id)%beta > patch_icpp(patch_id)%epsilon) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of spherical '// & - 'harmonic patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of spherical '// & + 'harmonic patch '//trim(iStr)//'. Exiting ...') end if @@ -471,8 +469,8 @@ contains patch_icpp(patch_id)%length_z <= 0d0) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of cuboid '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of cuboid '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -516,8 +514,8 @@ contains patch_icpp(patch_id)%radius <= 0d0) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of cylinder '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of cylinder '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -549,8 +547,8 @@ contains patch_icpp(patch_id)%normal(3) == dflt_real) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of plane sweep '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of plane sweep '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -581,8 +579,8 @@ contains patch_icpp(patch_id)%radii(3) == dflt_real) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of ellipsoid '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of ellipsoid '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -628,8 +626,8 @@ contains patch_icpp(patch_id)%radii(3) /= dflt_real) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'geometric parameters of inactive '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'geometric parameters of inactive '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -650,8 +648,8 @@ contains any(patch_icpp(patch_id)%alter_patch(patch_id:))) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'alteration rights of active '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'alteration rights of active '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -673,8 +671,8 @@ contains any(patch_icpp(patch_id)%alter_patch(1:))) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'alteration rights of inactive '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'alteration rights of inactive '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -705,8 +703,8 @@ contains patch_icpp(patch_id)%smooth_coeff /= dflt_real))) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'smoothing parameters of supported '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'smoothing parameters of supported '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -730,8 +728,8 @@ contains patch_icpp(patch_id)%smooth_coeff /= dflt_real) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'smoothing parameters of unsupported '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'smoothing parameters of unsupported '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -770,11 +768,11 @@ contains .or. & (model_eqns == 2 & .and. & - (any(patch_icpp(patch_id)%alpha_rho(1:num_fluids) < 0d0) ))) then + (any(patch_icpp(patch_id)%alpha_rho(1:num_fluids) < 0d0)))) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'primitive variables of active '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'primitive variables of active '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -789,8 +787,8 @@ contains (patch_icpp(patch_id)%alpha(num_fluids) == dflt_real)) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'primitive variables of active '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'primitive variables of active '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -823,8 +821,8 @@ contains patch_icpp(patch_id)%pi_inf /= dflt_real) then call s_mpi_abort('Inconsistency(ies) detected in '// & - 'primitive variables of inactive '// & - 'patch '//trim(iStr)//'. Exiting ...') + 'primitive variables of inactive '// & + 'patch '//trim(iStr)//'. Exiting ...') end if @@ -836,12 +834,12 @@ contains logical :: file_exists - inquire(file=patch_icpp(patch_id)%model%filepath, exist=file_exists) + inquire (file=patch_icpp(patch_id)%model%filepath, exist=file_exists) if (.not. file_exists) then - print '(A,I0,A)', 'Model file '//trim(patch_icpp(patch_id)%model%filepath)//& - ' requested by patch ', patch_id,' does not exist. Exiting ...' + print '(A,I0,A)', 'Model file '//trim(patch_icpp(patch_id)%model%filepath)// & + ' requested by patch ', patch_id, ' does not exist. Exiting ...' call s_mpi_abort() diff --git a/src/pre_process/m_checker.f90 b/src/pre_process/m_checker.f90 index 7f8d9b34c..2b75066d8 100644 --- a/src/pre_process/m_checker.f90 +++ b/src/pre_process/m_checker.f90 @@ -2,7 +2,7 @@ !!@file m_checker.f90 !!@brief Contains module m_checker -!> @brief The purpose of the module is to check for compatible input files +!> @brief The purpose of the module is to check for compatible input files module m_checker use m_global_parameters !< Definitions of the global parameters @@ -22,13 +22,13 @@ subroutine s_check_inputs() integer :: bub_fac !< !! For allowing an extra fluid_pp if there are subgrid bubbles character(len=5) :: iStr !< for int to string conversion - integer :: i + integer :: i logical :: dir_check !< !! Logical variable used to test the existence of folders #ifndef MFC_MPI if (parallel_io .eqv. .true.) then - print '(A)', 'MFC built with --no-mpi requires parallel_io=F. ' // & + print '(A)', 'MFC built with --no-mpi requires parallel_io=F. '// & 'Exiting ...' call s_mpi_abort() end if @@ -40,41 +40,41 @@ subroutine s_check_inputs() if (bubbles) then if (model_eqns /= 4 .and. model_eqns /= 2) then call s_mpi_abort('Unsupported combination of values of '// & - 'bubbles and model_eqns. '// & - 'Exiting ...') + 'bubbles and model_eqns. '// & + 'Exiting ...') elseif (nb < 1) then - call s_mpi_abort('The Ensemble-Averaged Bubble Model requires nb >= 1' // & - 'Exiting ...') + call s_mpi_abort('The Ensemble-Averaged Bubble Model requires nb >= 1'// & + 'Exiting ...') elseif (polydisperse .and. (nb == 1)) then call s_mpi_abort('Polydisperse bubble dynamics requires nb > 1 '// & - 'Exiting ...') + 'Exiting ...') elseif (polydisperse .and. (mod(nb, 2) == 0)) then call s_mpi_abort('nb must be odd '// & - 'Exiting ...') + 'Exiting ...') elseif (model_eqns == 4 .and. (rhoref == dflt_real)) then call s_mpi_abort('Unsupported combination of values of '// & - 'bubbles and rhoref. '// & - 'Exiting ...') + 'bubbles and rhoref. '// & + 'Exiting ...') elseif (model_eqns == 4 .and. (pref == dflt_real)) then call s_mpi_abort('Unsupported combination of values of '// & - 'bubbles and pref. '// & - 'Exiting ...') + 'bubbles and pref. '// & + 'Exiting ...') elseif (model_eqns == 4 .and. (num_fluids > 1)) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns and num_fluids. '// & - 'Exiting ...') + 'model_eqns and num_fluids. '// & + 'Exiting ...') elseif (R0ref == dflt_real) then call s_mpi_abort('Unsupported combination of values of '// & - 'bubbles and R0ref. '// & - 'Exiting ...') + 'bubbles and R0ref. '// & + 'Exiting ...') elseif (nb == dflt_int) then call s_mpi_abort('unsupported combination of values of '// & - 'bubbles and nb. '// & - 'exiting ...') + 'bubbles and nb. '// & + 'exiting ...') elseif (thermal > 3) then call s_mpi_abort('unsupported combination of values of '// & - 'bubbles and thermal. '// & - 'exiting ...') + 'bubbles and thermal. '// & + 'exiting ...') end if end if @@ -89,80 +89,80 @@ subroutine s_check_inputs() if (hypoelasticity .and. (model_eqns /= 2)) then call s_mpi_abort('hypoelasticity requires model_eqns = 2'// & - 'exiting ...') + 'exiting ...') end if ! phase change checkers. - if ( relax ) then - if ( model_eqns /= 3 ) then - call s_mpi_abort( 'phase change requires model_eqns = 3. ' // & - 'Exiting ...') - elseif ( ( relax_model .lt. 0 ) .or. ( relax_model .gt. 6 ) ) then - call s_mpi_abort( 'relax_model should be in between 0 and 6. ' // & - 'Exiting ...' ) - elseif ( ( palpha_eps .le. 0d0 ) .or. ( palpha_eps .ge. 1d0 ) .or. & - ( ptgalpha_eps .le. 0d0 ) .or. ( ptgalpha_eps .ge. 1d0 ) ) then - call s_mpi_abort( 'both palpha_eps and ptgalpha_eps must & - be in (0,1). ' // 'Exiting ...') - end if - - elseif ( ( relax_model /= dflt_int ) .or. ( palpha_eps /= dflt_real ) & - .or. ( ptgalpha_eps /= dflt_real ) ) then - call s_mpi_abort( 'relax is not set as true, but other phase change parameters have & - been modified. Either activate phase change or set the values to default. ' // 'Exiting ...') + if (relax) then + if (model_eqns /= 3) then + call s_mpi_abort('phase change requires model_eqns = 3. '// & + 'Exiting ...') + elseif ((relax_model < 0) .or. (relax_model > 6)) then + call s_mpi_abort('relax_model should be in between 0 and 6. '// & + 'Exiting ...') + elseif ((palpha_eps <= 0d0) .or. (palpha_eps >= 1d0) .or. & + (ptgalpha_eps <= 0d0) .or. (ptgalpha_eps >= 1d0)) then + call s_mpi_abort('both palpha_eps and ptgalpha_eps must & + & be in (0,1). '//'Exiting ...') + end if + + elseif ((relax_model /= dflt_int) .or. (palpha_eps /= dflt_real) & + .or. (ptgalpha_eps /= dflt_real)) then + call s_mpi_abort('relax is not set as true, but other phase change parameters have & +& been modified. Either activate phase change or set the values to default. '//'Exiting ...') end if if ((old_grid .neqv. .true.) .and. old_ic) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid and old_ic. Exiting ...') + 'values for old_grid and old_ic. Exiting ...') elseif ((old_grid .or. old_ic) .and. t_step_old == dflt_int) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid and old_ic and t_step_old. Exiting ...') + 'values for old_grid and old_ic and t_step_old. Exiting ...') - ! Constraints on dimensionality and the number of cells for the grid + ! Constraints on dimensionality and the number of cells for the grid elseif (m <= 0) then call s_mpi_abort('Unsupported choice for the value of m. '// & - 'Exiting ...') + 'Exiting ...') elseif (n < 0) then call s_mpi_abort('Unsupported choice for the value of n. '// & - 'Exiting ...') + 'Exiting ...') elseif (p < 0) then call s_mpi_abort('Unsupported choice for the value of p. '// & - 'Exiting ...') + 'Exiting ...') elseif (cyl_coord .and. p > 0 .and. mod(p, 2) /= 1) then call s_mpi_abort('Unsupported choice for the value of p. '// & - 'Total number of cells in azimuthal direction '// & - 'must be an even number. Exiting ...') + 'Total number of cells in azimuthal direction '// & + 'must be an even number. Exiting ...') elseif (n == 0 .and. p > 0) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and p. Exiting ...') + 'values for n and p. Exiting ...') elseif ((m + 1)*(n + 1)*(p + 1) & < & 2**(min(1, m) + min(1, n) + min(1, p))*num_procs) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for num_procs, m, n and p. '// & - 'Exiting ...') + 'values for num_procs, m, n and p. '// & + 'Exiting ...') - ! Constraints on domain boundaries locations in the x-direction + ! Constraints on domain boundaries locations in the x-direction elseif ((old_grid .and. x_domain%beg /= dflt_real) & .or. & ((old_grid .neqv. .true.) .and. & x_domain%beg == dflt_real)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid and x_domain%beg. '// & - 'Exiting ...') + 'values for old_grid and x_domain%beg. '// & + 'Exiting ...') elseif ((old_grid .and. x_domain%end /= dflt_real) & .or. & ((old_grid .neqv. .true.) .and. & x_domain%end == dflt_real)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid and x_domain%end. '// & - 'Exiting ...') + 'values for old_grid and x_domain%end. '// & + 'Exiting ...') elseif ((old_grid .neqv. .true.) & .and. & x_domain%beg >= x_domain%end) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid, x_domain%beg and '// & - 'x_domain%end. Exiting ...') + 'values for old_grid, x_domain%beg and '// & + 'x_domain%end. Exiting ...') end if if (cyl_coord) then ! Cartesian coordinates @@ -178,23 +178,23 @@ subroutine s_check_inputs() .or. & y_domain%beg >= y_domain%end) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'cyl_coord and n, y_domain%beg, or '// & - 'y_domain%end. Exiting ...') + 'cyl_coord and n, y_domain%beg, or '// & + 'y_domain%end. Exiting ...') elseif ((p == 0 .and. z_domain%beg /= dflt_real) & .or. & (p == 0 .and. z_domain%end /= dflt_real)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'cyl_coord and p, z_domain%beg, or '// & - 'z_domain%end. Exiting ...') + 'cyl_coord and p, z_domain%beg, or '// & + 'z_domain%end. Exiting ...') elseif (p > 0 .and. (z_domain%beg /= 0d0 & .or. & z_domain%end /= 2d0*pi)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'cyl_coord and p, z_domain%beg, or '// & - 'z_domain%end. Exiting ...') + 'cyl_coord and p, z_domain%beg, or '// & + 'z_domain%end. Exiting ...') end if - else + else ! Constraints on domain boundaries locations in the y-direction if ((n == 0 .and. y_domain%beg /= dflt_real) & @@ -206,8 +206,8 @@ subroutine s_check_inputs() ((old_grid .neqv. .true.) .and. & y_domain%beg == dflt_real)))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid, n and y_domain%beg. '// & - 'Exiting ...') + 'values for old_grid, n and y_domain%beg. '// & + 'Exiting ...') elseif ((n == 0 .and. y_domain%end /= dflt_real) & .or. & (n > 0 & @@ -217,16 +217,16 @@ subroutine s_check_inputs() ((old_grid .neqv. .true.) .and. & y_domain%end == dflt_real)))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid, n and y_domain%end. '// & - 'Exiting ...') + 'values for old_grid, n and y_domain%end. '// & + 'Exiting ...') elseif (n > 0 & .and. & (old_grid .neqv. .true.) & .and. & y_domain%beg >= y_domain%end) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid, n, y_domain%beg and '// & - 'y_domain%end. Exiting ...') + 'values for old_grid, n, y_domain%beg and '// & + 'y_domain%end. Exiting ...') ! Constraints on domain boundaries locations in the z-direction elseif ((p == 0 .and. z_domain%beg /= dflt_real) & @@ -238,8 +238,8 @@ subroutine s_check_inputs() ((old_grid .neqv. .true.) .and. & z_domain%beg == dflt_real)))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid, p and z_domain%beg. '// & - 'Exiting ...') + 'values for old_grid, p and z_domain%beg. '// & + 'Exiting ...') elseif ((p == 0 .and. z_domain%end /= dflt_real) & .or. & (p > 0 & @@ -249,59 +249,58 @@ subroutine s_check_inputs() ((old_grid .neqv. .true.) .and. & z_domain%end == dflt_real)))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid, p and z_domain%end. '// & - 'Exiting ...') + 'values for old_grid, p and z_domain%end. '// & + 'Exiting ...') elseif (p > 0 & .and. & (old_grid .neqv. .true.) & .and. & z_domain%beg >= z_domain%end) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid, p, z_domain%beg and '// & - 'z_domain%end. Exiting ...') + 'values for old_grid, p, z_domain%beg and '// & + 'z_domain%end. Exiting ...') end if end if if (loops_z < 1) then call s_mpi_abort('Unsupported choice for the value of loops_z. '// & - 'Exiting ...') + 'Exiting ...') elseif (loops_y < 1) then call s_mpi_abort('Unsupported choice for the value of loops_y. '// & - 'Exiting ...') + 'Exiting ...') end if - ! Constraints on the grid stretching in the x-direction if (stretch_x) then if (old_grid) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid and stretch_x. '// & - 'Exiting ...') + 'values for old_grid and stretch_x. '// & + 'Exiting ...') elseif (a_x == dflt_real) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_x and a_x. Exiting ...') + 'values for stretch_x and a_x. Exiting ...') elseif (x_a == dflt_real) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_x and x_a. Exiting ...') + 'values for stretch_x and x_a. Exiting ...') elseif (x_b == dflt_real) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_x and x_b. Exiting ...') + 'values for stretch_x and x_b. Exiting ...') elseif (x_a >= x_b) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_x, x_a and x_b. '// & - 'Exiting ...') + 'values for stretch_x, x_a and x_b. '// & + 'Exiting ...') elseif ((a_x + log(cosh(a_x*(x_domain%beg - x_a))) & + log(cosh(a_x*(x_domain%beg - x_b))) & - 2d0*log(cosh(0.5d0*a_x*(x_b - x_a))))/a_x <= 0d0) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for x_domain%beg, stretch_x, a_x, '// & - 'x_a, and x_b. Exiting ...') - elseif ( (a_x + log(cosh(a_x*(x_domain%end - x_a))) & + 'values for x_domain%beg, stretch_x, a_x, '// & + 'x_a, and x_b. Exiting ...') + elseif ((a_x + log(cosh(a_x*(x_domain%end - x_a))) & + log(cosh(a_x*(x_domain%end - x_b))) & - 2d0*log(cosh(0.5d0*a_x*(x_b - x_a))))/a_x <= 0d0) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for x_domain%end, stretch_x, a_x, '// & - 'x_a, and x_b. Exiting ...') + 'values for x_domain%end, stretch_x, a_x, '// & + 'x_a, and x_b. Exiting ...') end if end if @@ -309,82 +308,80 @@ subroutine s_check_inputs() ! Constraints on the grid stretching in the y-direction if (old_grid) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid and stretch_y. '// & - 'Exiting ...') + 'values for old_grid and stretch_y. '// & + 'Exiting ...') elseif (n == 0) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and stretch_y. Exiting ...') + 'values for n and stretch_y. Exiting ...') elseif (a_y == dflt_real) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_y and a_y. Exiting ...') + 'values for stretch_y and a_y. Exiting ...') elseif (y_a == dflt_real) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_y and y_a. Exiting ...') + 'values for stretch_y and y_a. Exiting ...') elseif (y_b == dflt_real) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_y and y_b. Exiting ...') + 'values for stretch_y and y_b. Exiting ...') elseif (y_a >= y_b) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_y, y_a and y_b. '// & - 'Exiting ...') + 'values for stretch_y, y_a and y_b. '// & + 'Exiting ...') elseif ((a_y + log(cosh(a_y*(y_domain%beg - y_a))) & + log(cosh(a_y*(y_domain%beg - y_b))) & - 2d0*log(cosh(0.5d0*a_y*(y_b - y_a))))/a_y <= 0d0) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for y_domain%beg, stretch_y, a_y, '// & - 'y_a, and y_b. Exiting ...') + 'values for y_domain%beg, stretch_y, a_y, '// & + 'y_a, and y_b. Exiting ...') elseif ((a_y + log(cosh(a_y*(y_domain%end - y_a))) & + log(cosh(a_y*(y_domain%end - y_b))) & - 2d0*log(cosh(0.5d0*a_y*(y_b - y_a))))/a_y <= 0d0) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for y_domain%end, stretch_y, a_y, '// & - 'y_a, and y_b. Exiting ...') + 'values for y_domain%end, stretch_y, a_y, '// & + 'y_a, and y_b. Exiting ...') end if end if - ! Constraints on the grid stretching in the z-direction if (stretch_z) then if (old_grid) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for old_grid and stretch_z. '// & - 'Exiting ...') + 'values for old_grid and stretch_z. '// & + 'Exiting ...') elseif (cyl_coord) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for cyl_coord and stretch_z. '// & - 'Exiting ...') + 'values for cyl_coord and stretch_z. '// & + 'Exiting ...') elseif (p == 0) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p and stretch_z. Exiting ...') + 'values for p and stretch_z. Exiting ...') elseif (a_z == dflt_real) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_z and a_z. Exiting ...') + 'values for stretch_z and a_z. Exiting ...') elseif (z_a == dflt_real) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_z and z_a. Exiting ...') + 'values for stretch_z and z_a. Exiting ...') elseif (z_b == dflt_real) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_z and z_b. Exiting ...') + 'values for stretch_z and z_b. Exiting ...') elseif (z_a >= z_b) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for stretch_z, z_a and z_b. '// & - 'Exiting ...') + 'values for stretch_z, z_a and z_b. '// & + 'Exiting ...') elseif ((a_z + log(cosh(a_z*(z_domain%beg - z_a))) & + log(cosh(a_z*(z_domain%beg - z_b))) & - 2d0*log(cosh(0.5d0*a_z*(z_b - z_a))))/a_z <= 0d0) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for z_domain%beg, stretch_z, a_z, '// & - 'z_a, and z_b. Exiting ...') + 'values for z_domain%beg, stretch_z, a_z, '// & + 'z_a, and z_b. Exiting ...') elseif ((a_z + log(cosh(a_z*(z_domain%end - z_a))) & + log(cosh(a_z*(z_domain%end - z_b))) & - 2d0*log(cosh(0.5d0*a_z*(z_b - z_a))))/a_z <= 0d0) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for z_domain%end, stretch_z, a_z, '// & - 'z_a, and z_b. Exiting ...') + 'values for z_domain%end, stretch_z, a_z, '// & + 'z_a, and z_b. Exiting ...') end if end if - ! Constraints on model equations and number of fluids in the flow if (all(model_eqns /= (/1, 2, 3, 4/))) then call s_mpi_abort('Unsupported value of model_eqns. Exiting ...') @@ -392,46 +389,46 @@ subroutine s_check_inputs() .and. & (num_fluids < 1 .or. num_fluids > num_fluids)) then call s_mpi_abort('Unsupported value of num_fluids. Exiting ...') - elseif (model_eqns == 1 .and. adv_alphan) then + elseif (model_eqns == 1 .and. adv_alphan) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns and adv_alphan. '// & - 'Exiting ...') - ! Constraints on the order of the WENO scheme + 'model_eqns and adv_alphan. '// & + 'Exiting ...') + ! Constraints on the order of the WENO scheme elseif (weno_order /= 1 .and. weno_order /= 3 & .and. & weno_order /= 5) then call s_mpi_abort('Unsupported choice for the value of '// & - 'weno_order. Exiting ...') + 'weno_order. Exiting ...') elseif (m + 1 < weno_order) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for m and weno_order. Exiting ...') + 'values for m and weno_order. Exiting ...') elseif (n > 0 .and. n + 1 < weno_order) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n and weno_order. Exiting ...') + 'values for n and weno_order. Exiting ...') elseif (p > 0 .and. p + 1 < weno_order) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p and weno_order. Exiting ...') + 'values for p and weno_order. Exiting ...') elseif ((m + 1)*(n + 1)*(p + 1) & < & weno_order**(min(1, m) + min(1, n) + min(1, p))*num_procs) & then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for num_procs, m, n, p and '// & - 'weno_order. Exiting ...') + 'values for num_procs, m, n, p and '// & + 'weno_order. Exiting ...') - ! Constraints on the boundary conditions in the x-direction + ! Constraints on the boundary conditions in the x-direction elseif (bc_x%beg < -16 .or. bc_x%beg > -1 .or. bc_x%beg == -14) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_x%beg. Exiting ...') + 'bc_x%beg. Exiting ...') elseif (bc_x%end < -16 .or. bc_x%end > -1 .or. bc_x%beg == -14) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_x%end. Exiting ...') + 'bc_x%end. Exiting ...') elseif ((bc_x%beg == -1 .and. bc_x%end /= -1) & .or. & (bc_x%end == -1 .and. bc_x%beg /= -1)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for bc_x%beg and bc_x%end. '// & - 'Exiting ...') + 'values for bc_x%beg and bc_x%end. '// & + 'Exiting ...') end if if (cyl_coord) then ! Cartesian coordinates @@ -443,48 +440,48 @@ subroutine s_check_inputs() .or. & (p == 0 .and. bc_y%beg /= -2))) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_y%beg. Exiting ...') + 'bc_y%beg. Exiting ...') elseif (bc_y%end /= dflt_int & .and. & (bc_y%end < -16 .or. bc_y%end > -1 .or. bc_y%end == -14)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_y%end. Exiting ...') + 'bc_y%end. Exiting ...') elseif ((n > 0 .and. bc_y%beg == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of n and '// & - 'bc_y%beg. Exiting ...') + 'bc_y%beg. Exiting ...') elseif ((n > 0 .and. bc_y%end == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of n and '// & - 'bc_y%end. Exiting ...') + 'bc_y%end. Exiting ...') - ! Constraints on the boundary conditions in the theta-direction + ! Constraints on the boundary conditions in the theta-direction elseif (bc_z%beg /= dflt_int & .and. & (bc_z%beg /= -1 .and. bc_z%beg /= -2)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_z%beg. Exiting ...') + 'bc_z%beg. Exiting ...') elseif (bc_z%end /= dflt_int & .and. & (bc_z%end /= -1 .and. bc_z%end /= -2)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_z%end. Exiting ...') + 'bc_z%end. Exiting ...') elseif ((p == 0 .and. bc_z%beg /= dflt_int) & .or. & (p > 0 .and. bc_z%beg == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of p and '// & - 'bc_z%beg. Exiting ...') + 'bc_z%beg. Exiting ...') elseif ((p == 0 .and. bc_z%end /= dflt_int) & .or. & (p > 0 .and. bc_z%end == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of p and '// & - 'bc_z%end. Exiting ...') + 'bc_z%end. Exiting ...') elseif (p > 0 & .and. & ((bc_z%beg == -1 .and. bc_z%end /= -1) & .or. & (bc_z%end == -1 .and. bc_z%beg /= -1))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p, bc_z%beg and bc_z%end. '// & - 'Exiting ...') + 'values for p, bc_z%beg and bc_z%end. '// & + 'Exiting ...') end if else @@ -494,62 +491,62 @@ subroutine s_check_inputs() .and. & (bc_y%beg < -16 .or. bc_y%beg > -1 .or. bc_y%beg == -14)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_y%beg. Exiting ...') + 'bc_y%beg. Exiting ...') elseif (bc_y%end /= dflt_int & .and. & (bc_y%end < -16 .or. bc_y%end > -1 .or. bc_y%end == -14)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_y%end. Exiting ...') + 'bc_y%end. Exiting ...') elseif ((n == 0 .and. bc_y%beg /= dflt_int) & .or. & (n > 0 .and. bc_y%beg == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of n and '// & - 'bc_y%beg. Exiting ...') + 'bc_y%beg. Exiting ...') elseif ((n == 0 .and. bc_y%end /= dflt_int) & .or. & (n > 0 .and. bc_y%end == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of n and '// & - 'bc_y%end. Exiting ...') + 'bc_y%end. Exiting ...') elseif (n > 0 & .and. & ((bc_y%beg == -1 .and. bc_y%end /= -1) & .or. & - (bc_y%end == -1 .and. bc_y%beg /= -1))) then + (bc_y%end == -1 .and. bc_y%beg /= -1))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for n, bc_y%beg and bc_y%end. '// & - 'Exiting ...') + 'values for n, bc_y%beg and bc_y%end. '// & + 'Exiting ...') - ! Constraints on the boundary conditions in the z-direction + ! Constraints on the boundary conditions in the z-direction elseif (bc_z%beg /= dflt_int & .and. & (bc_z%beg < -16 .or. bc_z%beg > -1 .or. bc_z%beg == -14)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_z%beg. Exiting ...') + 'bc_z%beg. Exiting ...') elseif (bc_z%end /= dflt_int & .and. & (bc_z%end < -16 .or. bc_z%end > -1 .or. bc_z%end == -14)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'bc_z%end. Exiting ...') + 'bc_z%end. Exiting ...') elseif (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == -13)) then call s_mpi_abort('Unsupported choice of boundary condition -13') elseif ((p == 0 .and. bc_z%beg /= dflt_int) & .or. & (p > 0 .and. bc_z%beg == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of p and '// & - 'bc_z%beg. Exiting ...') + 'bc_z%beg. Exiting ...') elseif ((p == 0 .and. bc_z%end /= dflt_int) & .or. & (p > 0 .and. bc_z%end == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of p and '// & - 'bc_z%end. Exiting ...') + 'bc_z%end. Exiting ...') elseif (p > 0 & .and. & ((bc_z%beg == -1 .and. bc_z%end /= -1) & .or. & (bc_z%end == -1 .and. bc_z%beg /= -1))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for p, bc_z%beg and bc_z%end. '// & - 'Exiting ...') + 'values for p, bc_z%beg and bc_z%end. '// & + 'Exiting ...') end if end if @@ -558,59 +555,59 @@ subroutine s_check_inputs() if (num_patches < 0 .or. num_patches > num_patches .or. & (num_patches == 0 .and. t_step_old == dflt_int)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'num_patches. Exiting ...') + 'num_patches. Exiting ...') ! Constraints on perturbing the initial condition elseif ((perturb_flow & - .and. & - (perturb_flow_fluid == dflt_int .or. perturb_flow_mag == dflt_real)) & + .and. & + (perturb_flow_fluid == dflt_int .or. perturb_flow_mag == dflt_real)) & .or. & ((perturb_flow .neqv. .true.) & - .and. & - (perturb_flow_fluid /= dflt_int .or. perturb_flow_mag /= dflt_real))) then + .and. & + (perturb_flow_fluid /= dflt_int .or. perturb_flow_mag /= dflt_real))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for perturb_flow, perturb_flow_fluid, and perturb_flow_mag. '// & - 'Exiting ...') + 'values for perturb_flow, perturb_flow_fluid, and perturb_flow_mag. '// & + 'Exiting ...') elseif ((perturb_flow_fluid > num_fluids) & .or. & (perturb_flow_fluid < 0 .and. perturb_flow_fluid /= dflt_int)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'perturb_flow_fluid. Exiting ...') + 'perturb_flow_fluid. Exiting ...') elseif ((perturb_sph .and. perturb_sph_fluid == dflt_int) & .or. & ((perturb_sph .neqv. .true.) .and. (perturb_sph_fluid /= dflt_int))) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for perturb_sph and perturb_sph_fluid. '// & - 'Exiting ...') + 'values for perturb_sph and perturb_sph_fluid. '// & + 'Exiting ...') elseif ((perturb_sph_fluid > num_fluids) & .or. & (perturb_sph_fluid < 0 .and. perturb_sph_fluid /= dflt_int)) then call s_mpi_abort('Unsupported choice for the value of '// & - 'perturb_sph_fluid. Exiting ...') + 'perturb_sph_fluid. Exiting ...') elseif ((any(fluid_rho /= dflt_real)) .and. (perturb_sph .neqv. .true.)) then call s_mpi_abort('Unsupported choices for values of perturb_sph '// & - 'and fluid_rho. Exiting ...') + 'and fluid_rho. Exiting ...') end if if (perturb_sph) then do i = 1, num_fluids - call s_int_to_str(i,iStr) + call s_int_to_str(i, iStr) if (fluid_rho(i) == dflt_real) then - call s_mpi_abort('Unsupported choice for value of fluid_rho('//& - trim(iStr)//'). Exiting ...') + call s_mpi_abort('Unsupported choice for value of fluid_rho('// & + trim(iStr)//'). Exiting ...') end if end do end if ! Constraints on the hypertangent velocity profile if ((vel_profile .eqv. .true.) .and. (n == 0)) then - call s_mpi_abort('Unsupported choices of the combination of values for '//& - 'vel_profile and n. Exiting ...') + call s_mpi_abort('Unsupported choices of the combination of values for '// & + 'vel_profile and n. Exiting ...') end if ! Constraints on the instability wave if ((instability_wave .eqv. .true.) .and. (n == 0)) then - call s_mpi_abort('Unsupported choices of the combination of values for '//& - 'instability_wave and n. Exiting ...') + call s_mpi_abort('Unsupported choices of the combination of values for '// & + 'instability_wave and n. Exiting ...') end if ! Constraints on the stiffened equation of state fluids parameters @@ -620,52 +617,52 @@ subroutine s_check_inputs() .and. & fluid_pp(i)%gamma <= 0d0) then call s_mpi_abort('Unsupported value of '// & - 'fluid_pp('//trim(iStr)//')%'// & - 'gamma. Exiting ...') + 'fluid_pp('//trim(iStr)//')%'// & + 'gamma. Exiting ...') elseif (model_eqns == 1 & .and. & - fluid_pp(i)%gamma /= dflt_real) then + fluid_pp(i)%gamma /= dflt_real) then call s_mpi_abort('Unsupported combination '// & - 'of values of model_eqns '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'gamma. Exiting ...') + 'of values of model_eqns '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'gamma. Exiting ...') elseif ((i <= num_fluids + bub_fac .and. fluid_pp(i)%gamma <= 0d0) & .or. & (i > num_fluids + bub_fac .and. fluid_pp(i)%gamma /= dflt_real)) & then - call s_mpi_abort( 'Unsupported combination '// & - 'of values of num_fluids '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'gamma. Exiting ...') + call s_mpi_abort('Unsupported combination '// & + 'of values of num_fluids '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'gamma. Exiting ...') elseif (fluid_pp(i)%pi_inf /= dflt_real & .and. & fluid_pp(i)%pi_inf < 0d0) then call s_mpi_abort('Unsupported value of '// & - 'fluid_pp('//trim(iStr)//')%'// & - 'pi_inf. Exiting ...') + 'fluid_pp('//trim(iStr)//')%'// & + 'pi_inf. Exiting ...') elseif (model_eqns == 1 & .and. & - fluid_pp(i)%pi_inf /= dflt_real) then + fluid_pp(i)%pi_inf /= dflt_real) then call s_mpi_abort('Unsupported combination '// & - 'of values of model_eqns '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'pi_inf. Exiting ...') + 'of values of model_eqns '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'pi_inf. Exiting ...') elseif ((i <= num_fluids + bub_fac .and. fluid_pp(i)%pi_inf < 0d0) & .or. & (i > num_fluids + bub_fac .and. fluid_pp(i)%pi_inf /= dflt_real)) & then call s_mpi_abort('Unsupported combination '// & - 'of values of num_fluids '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'pi_inf. Exiting ...') - elseif ( fluid_pp(i)%cv < 0d0 ) then + 'of values of num_fluids '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'pi_inf. Exiting ...') + elseif (fluid_pp(i)%cv < 0d0) then call s_mpi_abort('Unsupported value of '// & - 'fluid_pp('//trim(iStr)//')%'// & - 'cv. Make sure cv is positive. Exiting ...') + 'fluid_pp('//trim(iStr)//')%'// & + 'cv. Make sure cv is positive. Exiting ...') end if end do end subroutine s_check_inputs -end module m_checker +end module m_checker diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index 3782494f7..35d3fc097 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -148,10 +148,10 @@ contains end do !Outputting pb and mv for non-polytropic qbmm - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_num, '(I0)') r + (i-1)*nnode + sys_size + write (file_num, '(I0)') r + (i - 1)*nnode + sys_size file_loc = trim(t_step_dir)//'/pb'//trim(file_num) & //'.dat' open (1, FILE=trim(file_loc), FORM='unformatted', & @@ -163,7 +163,7 @@ contains do i = 1, nb do r = 1, nnode - write (file_num, '(I0)') r + (i-1)*nnode + sys_size + write (file_num, '(I0)') r + (i - 1)*nnode + sys_size file_loc = trim(t_step_dir)//'/mv'//trim(file_num) & //'.dat' open (1, FILE=trim(file_loc), FORM='unformatted', & @@ -201,7 +201,7 @@ contains open (2, FILE=trim(file_loc)) do j = 0, m - call s_convert_to_mixture_variables(q_cons_vf, j, 0, 0, rho, gamma, pi_inf, qv ) + call s_convert_to_mixture_variables(q_cons_vf, j, 0, 0, rho, gamma, pi_inf, qv) lit_gamma = 1d0/gamma + 1d0 @@ -223,13 +223,13 @@ contains write (2, FMT) x_cb(j), pres else if ((i >= bub_idx%beg) .and. (i <= bub_idx%end) .and. bubbles) then - if(qbmm) then - nbub = q_cons_vf(bubxb)%sf(j, 0, 0) + if (qbmm) then + nbub = q_cons_vf(bubxb)%sf(j, 0, 0) else do k = 1, nb nRtmp(k) = q_cons_vf(bub_idx%rs(k))%sf(j, 0, 0) end do - + call s_comp_n_from_cons(q_cons_vf(alf_idx)%sf(j, 0, 0), nRtmp, nbub, weight) end if @@ -251,10 +251,10 @@ contains close (2) end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -265,7 +265,7 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -296,10 +296,10 @@ contains end do close (2) end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -312,7 +312,7 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -342,10 +342,10 @@ contains end do close (2) end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -360,7 +360,7 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -409,15 +409,15 @@ contains file_loc = trim(case_dir)//'/restart_data/lustre_0' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then - call s_create_directory(trim(file_loc)) + call s_create_directory(trim(file_loc)) end if call s_create_directory(trim(file_loc)) end if call s_mpi_barrier() - call DelayFileAccess (proc_rank) + call DelayFileAccess(proc_rank) ! Initialize MPI data I/O call s_initialize_mpi_data(q_cons_vf) - + ! Open the file to write all flow variables write (file_loc, '(I0,A,i7.7,A)') t_step_start, '_', proc_rank, '.dat' file_loc = trim(restart_dir)//'/lustre_0'//trim(mpiiofs)//trim(file_loc) @@ -427,7 +427,7 @@ contains end if if (file_exist) call MPI_FILE_DELETE(file_loc, mpi_info_int, ierr) call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + mpi_info_int, ifile, ierr) ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) @@ -450,7 +450,7 @@ contains MPI_DOUBLE_PRECISION, status, ierr) end do !Additional variables pb and mv for non-polytropic qbmm - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) @@ -460,7 +460,7 @@ contains end if else do i = 1, sys_size !TODO: check if this is right - ! do i = 1, adv_idx%end + ! do i = 1, adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & @@ -473,7 +473,7 @@ contains else ! Initialize MPI data I/O call s_initialize_mpi_data(q_cons_vf) - + ! Open the file to write all flow variables write (file_loc, '(I0,A)') t_step_start, '.dat' file_loc = trim(restart_dir)//trim(mpiiofs)//trim(file_loc) @@ -482,7 +482,7 @@ contains call MPI_FILE_DELETE(file_loc, mpi_info_int, ierr) end if call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + mpi_info_int, ifile, ierr) ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) @@ -505,12 +505,12 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & MPI_DOUBLE_PRECISION, status, ierr) end do !Additional variables pb and mv for non-polytropic qbmm - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) @@ -518,28 +518,28 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & MPI_DOUBLE_PRECISION, status, ierr) end do end if else do i = 1, sys_size !TODO: check if this is right - ! do i = 1, adv_idx%end + ! do i = 1, adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & MPI_DOUBLE_PRECISION, status, ierr) end do end if call MPI_FILE_CLOSE(ifile, ierr) - endif + end if #endif end subroutine s_write_parallel_data_files ! --------------------------- diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index 84df94b63..ba58e2169 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -104,7 +104,7 @@ module m_global_parameters logical :: vel_profile !< Set hypertangent streamwise velocity profile logical :: instability_wave !< Superimpose instability waves to surrounding fluid flow - + ! Perturb density of surrounding air so as to break symmetry of grid logical :: perturb_flow integer :: perturb_flow_fluid !< Fluid to be perturbed with perturb_flow flag @@ -119,7 +119,6 @@ module m_global_parameters integer, allocatable, dimension(:) :: start_idx !< !! Starting cell-center index of local processor in global grid - #ifdef MFC_MPI type(mpi_io_var), public :: MPI_IO_DATA @@ -179,7 +178,6 @@ module m_global_parameters integer :: dist_type !1 = binormal, 2 = lognormal-normal integer :: R0_type !1 = simpson - !> @} !> @name Index variables used for m_variables_conversion @@ -245,7 +243,7 @@ contains ! Simulation algorithm parameters model_eqns = dflt_int relax = .false. - relax_model= dflt_int + relax_model = dflt_int palpha_eps = dflt_real ptgalpha_eps = dflt_real num_fluids = dflt_int @@ -275,10 +273,10 @@ contains do i = 1, num_patches_max patch_icpp(i)%geometry = dflt_int - patch_icpp(i)%model%scale(:) = 1d0 + patch_icpp(i)%model%scale(:) = 1d0 patch_icpp(i)%model%translate(:) = 0d0 - patch_icpp(i)%model%filepath(:) = ' ' - patch_icpp(i)%model%spc = 10 + patch_icpp(i)%model%filepath(:) = ' ' + patch_icpp(i)%model%spc = 10 patch_icpp(i)%x_centroid = dflt_real patch_icpp(i)%y_centroid = dflt_real patch_icpp(i)%z_centroid = dflt_real @@ -360,9 +358,9 @@ contains fluid_pp(i)%M_v = dflt_real fluid_pp(i)%mu_v = dflt_real fluid_pp(i)%k_v = dflt_real - fluid_pp(i)%cv = 0d0 - fluid_pp(i)%qv = 0d0 - fluid_pp(i)%qvp = 0d0 + fluid_pp(i)%cv = 0d0 + fluid_pp(i)%qv = 0d0 + fluid_pp(i)%qvp = 0d0 fluid_pp(i)%G = 0d0 end do @@ -488,21 +486,21 @@ contains end if !Initialize pref,rhoref for polytropic qbmm (done in s_initialize_nonpoly for non-polytropic) - if(.not. qbmm) then - if ( polytropic ) then + if (.not. qbmm) then + if (polytropic) then rhoref = 1.d0 pref = 1.d0 end if end if - !Initialize pb0,pv,pref,rhoref for polytropic qbmm (done in s_initialize_nonpoly for non-polytropic) - if(qbmm) then - if(polytropic) then - allocate(pb0(nb)) - if(Web == dflt_real) then + !Initialize pb0,pv,pref,rhoref for polytropic qbmm (done in s_initialize_nonpoly for non-polytropic) + if (qbmm) then + if (polytropic) then + allocate (pb0(nb)) + if (Web == dflt_real) then pb0 = pref - pb0 = pb0 / pref - pref = 1d0 + pb0 = pb0/pref + pref = 1d0 end if rhoref = 1d0 end if @@ -590,7 +588,6 @@ contains pref = 1.d0 end if - end if end if @@ -611,19 +608,19 @@ contains #ifdef MFC_MPI - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then allocate (MPI_IO_DATA%view(1:sys_size + 2*nb*4)) allocate (MPI_IO_DATA%var(1:sys_size + 2*nb*4)) else allocate (MPI_IO_DATA%view(1:sys_size)) - allocate (MPI_IO_DATA%var(1:sys_size)) + allocate (MPI_IO_DATA%var(1:sys_size)) end if do i = 1, sys_size allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) MPI_IO_DATA%var(i)%sf => null() end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*4 allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) MPI_IO_DATA%var(i)%sf => null() diff --git a/src/pre_process/m_initial_condition.fpp b/src/pre_process/m_initial_condition.fpp index 310d45711..8c0063f6e 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -73,15 +73,15 @@ contains ! Allocating the patch identities bookkeeping variable allocate (patch_id_fp(0:m, 0:n, 0:p)) - if(qbmm .and. .not. polytropic) then - !Allocate bubble pressure pb and vapor mass mv for non-polytropic qbmm at all quad nodes and R0 bins - allocate(pb%sf(0:m, & - 0:n, & - 0:p, 1:nnode, 1:nb)) - - allocate(mv%sf(0:m, & - 0:n, & - 0:p, 1:nnode, 1:nb)) + if (qbmm .and. .not. polytropic) then + !Allocate bubble pressure pb and vapor mass mv for non-polytropic qbmm at all quad nodes and R0 bins + allocate (pb%sf(0:m, & + 0:n, & + 0:p, 1:nnode, 1:nb)) + + allocate (mv%sf(0:m, & + 0:n, & + 0:p, 1:nnode, 1:nb)) end if ! Setting default values for conservative and primitive variables so ! that in the case that the initial condition is wrongly laid out on @@ -126,7 +126,7 @@ contains do i = 1, num_patches if (proc_rank == 0) then - print*, 'Processing patch', i + print *, 'Processing patch', i end if ! Spherical patch @@ -164,7 +164,7 @@ contains ! 3D STL patch elseif (patch_icpp(i)%geometry == 21) then call s_model(i, patch_id_fp, q_prim_vf) - + end if end do @@ -177,7 +177,7 @@ contains do i = 1, num_patches if (proc_rank == 0) then - print*, 'Processing patch', i + print *, 'Processing patch', i end if ! Circular patch @@ -199,7 +199,7 @@ contains ! Unimplemented patch (formerly isentropic vortex) elseif (patch_icpp(i)%geometry == 6) then call s_mpi_abort('This used to be the isentropic vortex patch, '// & - 'which no longer exists. See Examples. Exiting ...') + 'which no longer exists. See Examples. Exiting ...') ! Analytical function patch for testing purposes elseif (patch_icpp(i)%geometry == 7) then @@ -220,7 +220,7 @@ contains ! STL patch elseif (patch_icpp(i)%geometry == 21) then call s_model(i, patch_id_fp, q_prim_vf) - + end if end do @@ -233,7 +233,7 @@ contains do i = 1, num_patches if (proc_rank == 0) then - print*, 'Processing patch', i + print *, 'Processing patch', i end if ! Line segment patch @@ -262,13 +262,12 @@ contains call s_convert_primitive_to_conservative_variables(q_prim_vf, & q_cons_vf) - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !Initialize pb and mv call s_initialize_mv(q_cons_vf, mv%sf) call s_initialize_pb(q_cons_vf, mv%sf, pb%sf) end if - end subroutine s_generate_initial_condition ! -------------------------- subroutine s_perturb_sphere() ! ---------------------------------------- @@ -337,66 +336,66 @@ contains end subroutine s_perturb_surrounding_flow ! ---------------------------- - !> This subroutine computes velocity perturbations for a temporal mixing - !! layer with hypertangent mean streamwise velocity profile - !! obtained from linear stability analysis. For a 2D case, - !! instability waves with spatial wavenumbers, (4,0), (2,0), - !! and (1,0) are superposed. For a 3D waves, (4,4), (4,-4), + !> This subroutine computes velocity perturbations for a temporal mixing + !! layer with hypertangent mean streamwise velocity profile + !! obtained from linear stability analysis. For a 2D case, + !! instability waves with spatial wavenumbers, (4,0), (2,0), + !! and (1,0) are superposed. For a 3D waves, (4,4), (4,-4), !! (2,2), (2,-2), (1,1), (1,-1) areadded on top of 2D waves. subroutine s_superposition_instability_wave() ! ------------------------ - real(kind(0d0)), dimension(5,0:m,0:n,0:p) :: wave,wave1,wave2,wave_tmp - real(kind(0d0)) :: tr,ti - real(kind(0d0)) :: Lx,Lz - integer :: i,j,k - + real(kind(0d0)), dimension(5, 0:m, 0:n, 0:p) :: wave, wave1, wave2, wave_tmp + real(kind(0d0)) :: tr, ti + real(kind(0d0)) :: Lx, Lz + integer :: i, j, k + Lx = x_domain%end - x_domain%beg if (p > 0) then Lz = z_domain%end - z_domain%beg end if - + wave = 0d0 wave1 = 0d0 wave2 = 0d0 - + ! Compute 2D waves - call s_instability_wave(2*pi*4.0/Lx,0d0,tr,ti,wave_tmp,0d0) + call s_instability_wave(2*pi*4.0/Lx, 0d0, tr, ti, wave_tmp, 0d0) wave1 = wave1 + wave_tmp - call s_instability_wave(2*pi*2.0/Lx,0d0,tr,ti,wave_tmp,0d0) + call s_instability_wave(2*pi*2.0/Lx, 0d0, tr, ti, wave_tmp, 0d0) wave1 = wave1 + wave_tmp - call s_instability_wave(2*pi*1.0/Lx,0d0,tr,ti,wave_tmp,0d0) + call s_instability_wave(2*pi*1.0/Lx, 0d0, tr, ti, wave_tmp, 0d0) wave1 = wave1 + wave_tmp wave = wave1*0.05 if (p > 0) then ! Compute 3D waves with phase shifts. - call s_instability_wave(2*pi*4.0/Lx, 2*pi*4.0/Lz,tr,ti,wave_tmp,2*pi*11d0/31d0) + call s_instability_wave(2*pi*4.0/Lx, 2*pi*4.0/Lz, tr, ti, wave_tmp, 2*pi*11d0/31d0) wave2 = wave2 + wave_tmp - call s_instability_wave(2*pi*2.0/Lx, 2*pi*2.0/Lz,tr,ti,wave_tmp,2*pi*13d0/31d0) + call s_instability_wave(2*pi*2.0/Lx, 2*pi*2.0/Lz, tr, ti, wave_tmp, 2*pi*13d0/31d0) wave2 = wave2 + wave_tmp - call s_instability_wave(2*pi*1.0/Lx, 2*pi*1.0/Lz,tr,ti,wave_tmp,2*pi*17d0/31d0) + call s_instability_wave(2*pi*1.0/Lx, 2*pi*1.0/Lz, tr, ti, wave_tmp, 2*pi*17d0/31d0) wave2 = wave2 + wave_tmp - call s_instability_wave(2*pi*4.0/Lx,-2*pi*4.0/Lz,tr,ti,wave_tmp,2*pi*19d0/31d0) + call s_instability_wave(2*pi*4.0/Lx, -2*pi*4.0/Lz, tr, ti, wave_tmp, 2*pi*19d0/31d0) wave2 = wave2 + wave_tmp - call s_instability_wave(2*pi*2.0/Lx,-2*pi*2.0/Lz,tr,ti,wave_tmp,2*pi*23d0/31d0) + call s_instability_wave(2*pi*2.0/Lx, -2*pi*2.0/Lz, tr, ti, wave_tmp, 2*pi*23d0/31d0) wave2 = wave2 + wave_tmp - call s_instability_wave(2*pi*1.0/Lx,-2*pi*1.0/Lz,tr,ti,wave_tmp,2*pi*29d0/31d0) + call s_instability_wave(2*pi*1.0/Lx, -2*pi*1.0/Lz, tr, ti, wave_tmp, 2*pi*29d0/31d0) wave2 = wave2 + wave_tmp wave = wave + 0.15*wave2 end if - + ! Superpose velocity perturbuations (instability waves) to the velocity field do k = 0, p - do j = 0, n - do i = 0, m - q_prim_vf(mom_idx%beg )%sf(i,j,k) = q_prim_vf(mom_idx%beg )%sf(i,j,k)+wave(2,i,j,k) - q_prim_vf(mom_idx%beg+1)%sf(i,j,k) = q_prim_vf(mom_idx%beg+1)%sf(i,j,k)+wave(3,i,j,k) - if (p .gt. 0) then - q_prim_vf(mom_idx%beg+2)%sf(i,j,k) = q_prim_vf(mom_idx%beg+2)%sf(i,j,k)+wave(4,i,j,k) - end if - end do - end do + do j = 0, n + do i = 0, m + q_prim_vf(mom_idx%beg)%sf(i, j, k) = q_prim_vf(mom_idx%beg)%sf(i, j, k) + wave(2, i, j, k) + q_prim_vf(mom_idx%beg + 1)%sf(i, j, k) = q_prim_vf(mom_idx%beg + 1)%sf(i, j, k) + wave(3, i, j, k) + if (p > 0) then + q_prim_vf(mom_idx%beg + 2)%sf(i, j, k) = q_prim_vf(mom_idx%beg + 2)%sf(i, j, k) + wave(4, i, j, k) + end if + end do + end do end do - + end subroutine s_superposition_instability_wave ! ---------------------- !> This subroutine computes instability waves for a given set of spatial @@ -404,178 +403,173 @@ contains !! The eigenvalue problem is derived from the linearized !! Euler equations with parallel mean flow assumption !! (See Sandham 1989 PhD thesis for details). - subroutine s_instability_wave(alpha,beta,tr,ti,wave,shift) - real(kind(0d0)),intent(in) :: alpha, beta !< spatial wavenumbers - real(kind(0d0)),dimension(0:n) :: rho_mean, u_mean, t_mean !< mean profiles - real(kind(0d0)),dimension(0:n) :: drho_mean, du_mean, dt_mean !< y-derivatives of mean profiles - real(kind(0d0)),dimension(0:n,0:n) :: d !< differential operator in y dir - real(kind(0d0)),dimension(0:5*(n+1)-1,0:5*(n+1)-1) :: ar,ai,br,bi,ci !< matrices for eigenvalue problem - real(kind(0d0)),dimension(0:5*(n+1)-1,0:5*(n+1)-1) :: zr,zi !< eigenvectors - real(kind(0d0)),dimension(0:5*(n+1)-1) :: wr,wi !< eigenvalues - real(kind(0d0)),dimension(0:5*(n+1)-1) :: fv1,fv2,fv3 !< temporary memory - real(kind(0d0)) :: tr,ti !< most unstable eigenvalue - real(kind(0d0)),dimension(0:5*(n+1)-1) :: vr,vi,vnr,vni !< most unstable eigenvector and normalized one - real(kind(0d0)),dimension(5,0:m,0:n,0:p) :: wave !< instability wave + subroutine s_instability_wave(alpha, beta, tr, ti, wave, shift) + real(kind(0d0)), intent(in) :: alpha, beta !< spatial wavenumbers + real(kind(0d0)), dimension(0:n) :: rho_mean, u_mean, t_mean !< mean profiles + real(kind(0d0)), dimension(0:n) :: drho_mean, du_mean, dt_mean !< y-derivatives of mean profiles + real(kind(0d0)), dimension(0:n, 0:n) :: d !< differential operator in y dir + real(kind(0d0)), dimension(0:5*(n + 1) - 1, 0:5*(n + 1) - 1) :: ar, ai, br, bi, ci !< matrices for eigenvalue problem + real(kind(0d0)), dimension(0:5*(n + 1) - 1, 0:5*(n + 1) - 1) :: zr, zi !< eigenvectors + real(kind(0d0)), dimension(0:5*(n + 1) - 1) :: wr, wi !< eigenvalues + real(kind(0d0)), dimension(0:5*(n + 1) - 1) :: fv1, fv2, fv3 !< temporary memory + real(kind(0d0)) :: tr, ti !< most unstable eigenvalue + real(kind(0d0)), dimension(0:5*(n + 1) - 1) :: vr, vi, vnr, vni !< most unstable eigenvector and normalized one + real(kind(0d0)), dimension(5, 0:m, 0:n, 0:p) :: wave !< instability wave real(kind(0d0)) :: shift !< phase shift - real(kind(0d0)) :: gam,pi_inf,rho1,mach,c1 + real(kind(0d0)) :: gam, pi_inf, rho1, mach, c1 integer :: ierr integer :: j, k, l !< generic loop iterators integer :: ii, jj !< block matrix indices ! Set fluid flow properties gam = 1.+1./fluid_pp(1)%gamma - pi_inf = fluid_pp(1)%pi_inf*(gam-1.)/gam + pi_inf = fluid_pp(1)%pi_inf*(gam - 1.)/gam if (bubbles .and. num_fluids == 1) then - rho1 = patch_icpp(1)%alpha_rho(1)/(1d0-patch_icpp(1)%alpha(1)) + rho1 = patch_icpp(1)%alpha_rho(1)/(1d0 - patch_icpp(1)%alpha(1)) else rho1 = patch_icpp(1)%alpha_rho(1)/patch_icpp(1)%alpha(1) end if - c1 = sqrt((gam*(patch_icpp(1)%pres+pi_inf))/rho1) + c1 = sqrt((gam*(patch_icpp(1)%pres + pi_inf))/rho1) mach = 1./c1 ! Assign mean profiles - do j=0,n - u_mean(j)=tanh(y_cc(j)) - t_mean(j)=1+0.5*(gam-1)*mach**2*(1-u_mean(j)**2) - rho_mean(j)=1/T_mean(j) + do j = 0, n + u_mean(j) = tanh(y_cc(j)) + t_mean(j) = 1 + 0.5*(gam - 1)*mach**2*(1 - u_mean(j)**2) + rho_mean(j) = 1/T_mean(j) end do - + ! Compute differential operator in y-dir ! based on 4th order central difference (inner) ! and 2nd order central difference (near boundaries) - dy = y_cc(1)-y_cc(0) - d=0d0 - d(1,0)=-1/(2*dy) - d(1,2)= 1/(2*dy) - do j=2,n-2 - d(j,j-2)= 1/(12*dy) - d(j,j-1)=-8/(12*dy) - d(j,j+1)= 8/(12*dy) - d(j,j+2)=-1/(12*dy) + dy = y_cc(1) - y_cc(0) + d = 0d0 + d(1, 0) = -1/(2*dy) + d(1, 2) = 1/(2*dy) + do j = 2, n - 2 + d(j, j - 2) = 1/(12*dy) + d(j, j - 1) = -8/(12*dy) + d(j, j + 1) = 8/(12*dy) + d(j, j + 2) = -1/(12*dy) end do - d(n-1,n-2)=-1/(2*dy) - d(n-1,n) = 1/(2*dy) - + d(n - 1, n - 2) = -1/(2*dy) + d(n - 1, n) = 1/(2*dy) + ! Compute y-derivatives of rho, u, T - do j=0,n - drho_mean(j)=0 - du_mean(j)=0 - dt_mean(j)=0 - do k=0,n - drho_mean(j) = drho_mean(j)+d(j,k)*rho_mean(k) - du_mean(j) = du_mean(j)+d(j,k)*u_mean(k) - dt_mean(j) = dt_mean(j)+d(j,k)*t_mean(k) + do j = 0, n + drho_mean(j) = 0 + du_mean(j) = 0 + dt_mean(j) = 0 + do k = 0, n + drho_mean(j) = drho_mean(j) + d(j, k)*rho_mean(k) + du_mean(j) = du_mean(j) + d(j, k)*u_mean(k) + dt_mean(j) = dt_mean(j) + d(j, k)*t_mean(k) end do end do - + ! Compute B and C, then A = B + C ! B includes terms without differential operator, and ! C includes terms with differential operator - br=0d0 - bi=0d0 - ci=0d0 - do j=0,n - ii = 1; jj = 1; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = alpha*u_mean(j); - ii = 1; jj = 2; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = alpha*rho_mean(j); - ii = 1; jj = 3; bi((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = -drho_mean(j); - ii = 1; jj = 4; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = beta*rho_mean(j); - - ii = 2; jj = 1; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = alpha*t_mean(j)/(rho_mean(j)*gam*mach**2); - ii = 2; jj = 2; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = alpha*u_mean(j); - ii = 2; jj = 3; bi((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = -du_mean(j); - ii = 2; jj = 5; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = alpha/(gam*mach**2); - - ii = 3; jj = 1; bi((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = -dt_mean(j)/(rho_mean(j)*gam*mach**2); - ii = 3; jj = 3; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = alpha*u_mean(j); - ii = 3; jj = 5; bi((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = -drho_mean(j)/(rho_mean(j)*gam*mach**2); - - ii = 4; jj = 1; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = beta*t_mean(j)/(rho_mean(j)*gam*mach**2); - ii = 4; jj = 4; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = alpha*u_mean(j); - ii = 4; jj = 5; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = beta/(gam*mach**2); - - ii = 5; jj = 2; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = (gam-1)*alpha/rho_mean(j); - ii = 5; jj = 3; bi((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = -dt_mean(j); - ii = 5; jj = 4; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = (gam-1)*beta/rho_mean(j); - ii = 5; jj = 5; br((ii-1)*(n+1)+j,(jj-1)*(n+1)+j) = alpha*u_mean(j); - - do k=0,n - ii = 1; jj = 3; ci((ii-1)*(n+1)+j,(jj-1)*(n+1)+k) = -rho_mean(j)*d(j,k); - ii = 3; jj = 1; ci((ii-1)*(n+1)+j,(jj-1)*(n+1)+k) = -t_mean(j)*d(j,k)/(rho_mean(j)*gam*mach**2); - ii = 3; jj = 5; ci((ii-1)*(n+1)+j,(jj-1)*(n+1)+k) = -d(j,k)/(gam*mach**2); - ii = 5; jj = 3; ci((ii-1)*(n+1)+j,(jj-1)*(n+1)+k) = -(gam-1)*d(j,k)/rho_mean(j); + br = 0d0 + bi = 0d0 + ci = 0d0 + do j = 0, n + ii = 1; jj = 1; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = alpha*u_mean(j); + ii = 1; jj = 2; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = alpha*rho_mean(j); + ii = 1; jj = 3; bi((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = -drho_mean(j); + ii = 1; jj = 4; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = beta*rho_mean(j); + ii = 2; jj = 1; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = alpha*t_mean(j)/(rho_mean(j)*gam*mach**2); + ii = 2; jj = 2; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = alpha*u_mean(j); + ii = 2; jj = 3; bi((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = -du_mean(j); + ii = 2; jj = 5; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = alpha/(gam*mach**2); + ii = 3; jj = 1; bi((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = -dt_mean(j)/(rho_mean(j)*gam*mach**2); + ii = 3; jj = 3; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = alpha*u_mean(j); + ii = 3; jj = 5; bi((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = -drho_mean(j)/(rho_mean(j)*gam*mach**2); + ii = 4; jj = 1; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = beta*t_mean(j)/(rho_mean(j)*gam*mach**2); + ii = 4; jj = 4; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = alpha*u_mean(j); + ii = 4; jj = 5; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = beta/(gam*mach**2); + ii = 5; jj = 2; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = (gam - 1)*alpha/rho_mean(j); + ii = 5; jj = 3; bi((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = -dt_mean(j); + ii = 5; jj = 4; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = (gam - 1)*beta/rho_mean(j); + ii = 5; jj = 5; br((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + j) = alpha*u_mean(j); + do k = 0, n + ii = 1; jj = 3; ci((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + k) = -rho_mean(j)*d(j, k); + ii = 3; jj = 1; ci((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + k) = -t_mean(j)*d(j, k)/(rho_mean(j)*gam*mach**2); + ii = 3; jj = 5; ci((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + k) = -d(j, k)/(gam*mach**2); + ii = 5; jj = 3; ci((ii - 1)*(n + 1) + j, (jj - 1)*(n + 1) + k) = -(gam - 1)*d(j, k)/rho_mean(j); end do end do ar = br - ai = bi+ci - + ai = bi + ci + ! Compute eigenvalues and eigenvectors - call cg(5*(n+1),5*(n+1),ar,ai,wr,wi,zr,zi,fv1,fv2,fv3,ierr) + call cg(5*(n + 1), 5*(n + 1), ar, ai, wr, wi, zr, zi, fv1, fv2, fv3, ierr) ! Generate instability wave - call s_generate_wave(5*(n+1),wr,wi,zr,zi,alpha,beta,wave,shift) + call s_generate_wave(5*(n + 1), wr, wi, zr, zi, alpha, beta, wave, shift) end subroutine s_instability_wave !> This subroutine generates an instability wave using the most unstable - !! eigenvalue and corresponding eigenvector among the + !! eigenvalue and corresponding eigenvector among the !! given set of eigenvalues and eigenvectors. - subroutine s_generate_wave(nl,wr,wi,zr,zi,alpha,beta,wave,shift) + subroutine s_generate_wave(nl, wr, wi, zr, zi, alpha, beta, wave, shift) integer nl - real(kind(0d0)), dimension(0:nl-1) :: wr,wi !< eigenvalues - real(kind(0d0)), dimension(0:nl-1,0:nl-1) :: zr,zi !< eigenvectors - real(kind(0d0)), dimension(0:nl-1) :: vr,vi,vnr,vni !< most unstable eigenvector - real(kind(0d0)), dimension(5,0:m,0:n,0:p) :: wave - real(kind(0d0)) :: alpha,beta,ang,shift + real(kind(0d0)), dimension(0:nl - 1) :: wr, wi !< eigenvalues + real(kind(0d0)), dimension(0:nl - 1, 0:nl - 1) :: zr, zi !< eigenvectors + real(kind(0d0)), dimension(0:nl - 1) :: vr, vi, vnr, vni !< most unstable eigenvector + real(kind(0d0)), dimension(5, 0:m, 0:n, 0:p) :: wave + real(kind(0d0)) :: alpha, beta, ang, shift real(kind(0d0)) :: norm - real(kind(0d0)) :: tr,ti,cr,ci !< temporary memory + real(kind(0d0)) :: tr, ti, cr, ci !< temporary memory integer idx - integer i,j,k - + integer i, j, k + ! Find the most unstable eigenvalue and corresponding eigenvector - k=0 - do i=1,nl-1 - if (wi(i) .gt. wi(k)) then + k = 0 + do i = 1, nl - 1 + if (wi(i) > wi(k)) then k = i end if end do - vr = zr(:,k) - vi = zi(:,k) + vr = zr(:, k) + vi = zi(:, k) ! Normalize the eigenvector by its component with the largest modulus. norm = 0d0 - do i=0,nl-1 - if (dsqrt(vr(i)**2+vi(i)**2) .gt. norm) then + do i = 0, nl - 1 + if (dsqrt(vr(i)**2 + vi(i)**2) > norm) then idx = i - norm = dsqrt(vr(i)**2+vi(i)**2) + norm = dsqrt(vr(i)**2 + vi(i)**2) end if end do tr = vr(idx) ti = vi(idx) - do i=0,nl-1 - call cdiv(vr(i),vi(i),tr,ti,cr,ci) + do i = 0, nl - 1 + call cdiv(vr(i), vi(i), tr, ti, cr, ci) vnr(i) = cr vni(i) = ci end do ! Generate an instability wave - do i=0,m - do j=0,n - do k=0,p - if (beta .eq. 0) then - ang = alpha*x_cc(i) - else - ang = alpha*x_cc(i)+beta*z_cc(k)+shift - end if - wave(1,i,j,k) = vnr(j)*cos(ang)-vni(j)*sin(ang) ! rho - wave(2,i,j,k) = vnr((n+1)+j)*cos(ang)-vni((n+1)+j)*sin(ang) ! u - wave(3,i,j,k) = vnr(2*(n+1)+j)*cos(ang)-vni(2*(n+1)+j)*sin(ang) ! v - wave(4,i,j,k) = vnr(3*(n+1)+j)*cos(ang)-vni(3*(n+1)+j)*sin(ang) ! w - wave(5,i,j,k) = vnr(4*(n+1)+j)*cos(ang)-vni(4*(n+1)+j)*sin(ang) ! T - end do - end do + do i = 0, m + do j = 0, n + do k = 0, p + if (beta == 0) then + ang = alpha*x_cc(i) + else + ang = alpha*x_cc(i) + beta*z_cc(k) + shift + end if + wave(1, i, j, k) = vnr(j)*cos(ang) - vni(j)*sin(ang) ! rho + wave(2, i, j, k) = vnr((n + 1) + j)*cos(ang) - vni((n + 1) + j)*sin(ang) ! u + wave(3, i, j, k) = vnr(2*(n + 1) + j)*cos(ang) - vni(2*(n + 1) + j)*sin(ang) ! v + wave(4, i, j, k) = vnr(3*(n + 1) + j)*cos(ang) - vni(3*(n + 1) + j)*sin(ang) ! w + wave(5, i, j, k) = vnr(4*(n + 1) + j)*cos(ang) - vni(4*(n + 1) + j)*sin(ang) ! T + end do + end do end do - + end subroutine s_generate_wave !> Deallocation procedures for the module diff --git a/src/pre_process/m_model.fpp b/src/pre_process/m_model.fpp index 29b38c6e5..1ad53fbbe 100644 --- a/src/pre_process/m_model.fpp +++ b/src/pre_process/m_model.fpp @@ -24,28 +24,28 @@ contains !> This procedure reads a binary STL file. subroutine s_read_stl_binary(filepath, model) - character(LEN=*), intent(IN) :: filepath - type(t_model), intent(OUT) :: model + character(LEN=*), intent(IN) :: filepath + type(t_model), intent(OUT) :: model integer :: i, j, iunit, iostat character(kind=c_char, len=80) :: header - integer (kind=c_int32_t) :: nTriangles + integer(kind=c_int32_t) :: nTriangles - real (kind=c_float) :: normal(3), v(3, 3) - integer(kind=c_int16_t) :: attribute + real(kind=c_float) :: normal(3), v(3, 3) + integer(kind=c_int16_t) :: attribute - open(newunit=iunit, file=filepath, action='READ', & - form='UNFORMATTED', status='OLD', iostat=iostat, & - access='STREAM') + open (newunit=iunit, file=filepath, action='READ', & + form='UNFORMATTED', status='OLD', iostat=iostat, & + access='STREAM') if (iostat /= 0) then print *, "Error: could not open Binary STL file ", filepath - + call s_mpi_abort() end if - read(iunit, iostat=iostat) header, nTriangles + read (iunit, iostat=iostat) header, nTriangles if (iostat /= 0) then print *, "Error: could not read header from Binary STL file ", filepath @@ -54,57 +54,57 @@ contains end if model%ntrs = nTriangles - - allocate(model%trs(model%ntrs)) + + allocate (model%trs(model%ntrs)) do i = 1, model%ntrs - read(iunit) normal(:), v(1,:), v(2,:), v(3,:), attribute + read (iunit) normal(:), v(1, :), v(2, :), v(3, :), attribute model%trs(i)%v = v model%trs(i)%n = normal end do - close(iunit) + close (iunit) end subroutine s_read_stl_binary !> This procedure reads an ASCII STL file. subroutine s_read_stl_ascii(filepath, model) - character(LEN=*), intent(IN) :: filepath - type(t_model), intent(OUT) :: model + character(LEN=*), intent(IN) :: filepath + type(t_model), intent(OUT) :: model integer :: i, j, iunit, iostat character(80) :: line - open(newunit=iunit, file=filepath, action='READ', & - form='FORMATTED', status='OLD', iostat=iostat, & - access='STREAM') - + open (newunit=iunit, file=filepath, action='READ', & + form='FORMATTED', status='OLD', iostat=iostat, & + access='STREAM') + if (iostat /= 0) then print *, "Error: could not open ASCII STL file ", filepath - + call s_mpi_abort() end if model%ntrs = 0 do - if (.not. f_read_line(iunit, line)) exit + if (.not. f_read_line(iunit, line)) exit if (line(1:6) == "facet ") then model%ntrs = model%ntrs + 1 end if end do - allocate(model%trs(model%ntrs)) + allocate (model%trs(model%ntrs)) - rewind(iunit) + rewind (iunit) i = 1 do if (.not. f_read_line(iunit, line)) exit - + if (line(1:5) == "solid") cycle if (line(1:8) == "endsolid") exit @@ -115,10 +115,10 @@ contains end if call s_skip_ignored_lines(iunit) - read(line(13:), *) model%trs(i)%n + read (line(13:), *) model%trs(i)%n call s_skip_ignored_lines(iunit) - read(iunit, '(A)') line + read (iunit, '(A)') line do j = 1, 3 if (.not. f_read_line(iunit, line)) exit @@ -130,7 +130,7 @@ contains end if call s_skip_ignored_lines(iunit) - read(line(7:), *) model%trs(i)%v(j,:) + read (line(7:), *) model%trs(i)%v(j, :) end do if (.not. f_read_line(iunit, line)) exit @@ -150,63 +150,63 @@ contains !> This procedure reads an STL file. subroutine s_read_stl(filepath, model) - character(LEN=*), intent(IN) :: filepath - type(t_model), intent(OUT) :: model + character(LEN=*), intent(IN) :: filepath + type(t_model), intent(OUT) :: model integer :: iunit, iostat character(80) :: line - open(newunit=iunit, file=filepath, action='READ', & - form='FORMATTED', status='OLD', iostat=iostat, & - access='STREAM') + open (newunit=iunit, file=filepath, action='READ', & + form='FORMATTED', status='OLD', iostat=iostat, & + access='STREAM') if (iostat /= 0) then print *, "Error: could not open STL file ", filepath - + call s_mpi_abort() end if - read(iunit, '(A)') line - - close(iunit) + read (iunit, '(A)') line + + close (iunit) if (line(1:5) == "solid") then call s_read_stl_ascii(filepath, model) else call s_read_stl_binary(filepath, model) end if - + end subroutine !> This procedure reads an OBJ file. subroutine s_read_obj(filepath, model) - character(LEN=*), intent(IN) :: filepath - type(t_model), intent(OUT) :: model + character(LEN=*), intent(IN) :: filepath + type(t_model), intent(OUT) :: model integer :: i, j, k, l, iunit, iostat, nVertices - t_vec3, allocatable :: vertices(:,:) - + t_vec3, allocatable :: vertices(:, :) + character(80) :: line - open(newunit=iunit, file=filepath, action='READ', & - form='FORMATTED', status='OLD', iostat=iostat, & - access='STREAM') + open (newunit=iunit, file=filepath, action='READ', & + form='FORMATTED', status='OLD', iostat=iostat, & + access='STREAM') if (iostat /= 0) then print *, "Error: could not open model file ", filepath - + call s_mpi_abort() end if - nVertices = 0 + nVertices = 0 model%ntrs = 0 do - if (.not. f_read_line(iunit, line)) exit + if (.not. f_read_line(iunit, line)) exit - select case(line(1:2)) + select case (line(1:2)) case ("v ") nVertices = nVertices + 1 case ("f ") @@ -214,30 +214,30 @@ contains end select end do - rewind(iunit) + rewind (iunit) - allocate(vertices(nVertices, 1:3)) - allocate(model%trs(model%ntrs)) + allocate (vertices(nVertices, 1:3)) + allocate (model%trs(model%ntrs)) i = 1 j = 1 - + do if (.not. f_read_line(iunit, line)) exit - + select case (line(1:2)) case ("g ") case ("vn") case ("vt") case ("l ") case ("v ") - read(line(3:), *) vertices(i,:) + read (line(3:), *) vertices(i, :) i = i + 1 case ("f ") - read(line(3:), *) k, l, j - model%trs(j)%v(1,:) = vertices(k,:) - model%trs(j)%v(2,:) = vertices(l,:) - model%trs(j)%v(3,:) = vertices(j,:) + read (line(3:), *) k, l, j + model%trs(j)%v(1, :) = vertices(k, :) + model%trs(j)%v(2, :) = vertices(l, :) + model%trs(j)%v(3, :) = vertices(j, :) j = j + 1 case default print *, "Error: unknown line type in OBJ file ", filepath @@ -247,22 +247,22 @@ contains end select end do - deallocate(vertices) + deallocate (vertices) + + close (iunit) - close(iunit) - end subroutine !> This procedure reads a mesh from a file. !! @param filepath Path to the file to read. !! @return The model read from the file. function f_model_read(filepath) result(model) - + character(LEN=*), intent(IN) :: filepath type(t_model) :: model - select case (filepath(len(trim(filepath))-3:len(trim(filepath)))) + select case (filepath(len(trim(filepath)) - 3:len(trim(filepath)))) case (".stl") call s_read_stl(filepath, model) case (".obj") @@ -279,26 +279,26 @@ contains subroutine s_write_stl(filepath, model) character(LEN=*), intent(IN) :: filepath - type(t_model), intent(IN) :: model + type(t_model), intent(IN) :: model integer :: i, j, iunit, iostat character(kind=c_char, len=80), parameter :: header = "Model file written by MFC." - integer (kind=c_int32_t) :: nTriangles - real (kind=c_float) :: normal(3), v(3) - integer (kind=c_int16_t) :: attribute + integer(kind=c_int32_t) :: nTriangles + real(kind=c_float) :: normal(3), v(3) + integer(kind=c_int16_t) :: attribute - open(newunit=iunit, file=filepath, action='WRITE', & - form='UNFORMATTED', iostat=iostat, access='STREAM') + open (newunit=iunit, file=filepath, action='WRITE', & + form='UNFORMATTED', iostat=iostat, access='STREAM') if (iostat /= 0) then print *, "Error: could not open STL file ", filepath - + call s_mpi_abort() end if nTriangles = model%ntrs - write(iunit, iostat=iostat) header, nTriangles + write (iunit, iostat=iostat) header, nTriangles if (iostat /= 0) then print *, "Error: could not write header to STL file ", filepath @@ -308,18 +308,18 @@ contains do i = 1, model%ntrs normal = model%trs(i)%n - write(iunit) normal + write (iunit) normal do j = 1, 3 - v = model%trs(i)%v(j,:) - write(iunit) v(:) + v = model%trs(i)%v(j, :) + write (iunit) v(:) end do attribute = 0 - write(iunit) attribute + write (iunit) attribute end do - close(iunit) + close (iunit) end subroutine s_write_stl @@ -327,34 +327,34 @@ contains subroutine s_write_obj(filepath, model) character(LEN=*), intent(IN) :: filepath - type(t_model), intent(IN) :: model + type(t_model), intent(IN) :: model integer :: iunit, iostat integer :: i, j - open(newunit=iunit, file=filepath, action='WRITE', & - form='FORMATTED', iostat=iostat, access='STREAM') - + open (newunit=iunit, file=filepath, action='WRITE', & + form='FORMATTED', iostat=iostat, access='STREAM') + if (iostat /= 0) then print *, "Error: could not open OBJ file ", filepath - + call s_mpi_abort() end if - write(iunit, '(A)') "# Model file written by MFC." + write (iunit, '(A)') "# Model file written by MFC." do i = 1, model%ntrs do j = 1, 3 - write(iunit, '(A, " ", (f30.20), " ", (f30.20), " ", (f30.20))') & - "v", model%trs(i)%v(j,1), model%trs(i)%v(j,2), model%trs(i)%v(j,3) + write (iunit, '(A, " ", (f30.20), " ", (f30.20), " ", (f30.20))') & + "v", model%trs(i)%v(j, 1), model%trs(i)%v(j, 2), model%trs(i)%v(j, 3) end do - write(iunit, '(A, " ", I0, " ", I0, " ", I0)') & - "f", i*3-2, i*3-1, i*3 + write (iunit, '(A, " ", I0, " ", I0, " ", I0)') & + "f", i*3 - 2, i*3 - 1, i*3 end do - close(iunit) + close (iunit) end subroutine s_write_obj @@ -362,11 +362,11 @@ contains !! @param filepath Path to the file to write. !! @param triangles Triangles to write. subroutine s_model_write(filepath, model) - + character(LEN=*), intent(IN) :: filepath - type(t_model), intent(IN) :: model + type(t_model), intent(IN) :: model - select case (filepath(len(trim(filepath))-3:len(trim(filepath)))) + select case (filepath(len(trim(filepath)) - 3:len(trim(filepath)))) case (".stl") call s_write_stl(filepath, model) case (".obj") @@ -384,13 +384,13 @@ contains type(t_model), intent(INOUT) :: model - deallocate(model%trs) + deallocate (model%trs) end subroutine s_model_free function f_read_line(iunit, line) result(bIsLine) - integer, intent(IN) :: iunit + integer, intent(IN) :: iunit character(80), intent(OUT) :: line logical :: bIsLine @@ -399,7 +399,7 @@ contains bIsLine = .true. do - read(iunit, '(A)', iostat=iostat) line + read (iunit, '(A)', iostat=iostat) line if (iostat < 0) then bIsLine = .false. @@ -424,9 +424,9 @@ contains character(80) :: line if (f_read_line(iunit, line)) then - backspace(iunit) + backspace (iunit) end if - + end subroutine s_skip_ignored_lines !> This procedure, recursively, finds whether a point is inside an octree. @@ -438,30 +438,30 @@ contains function f_model_is_inside(model, point, spacing, spc) result(fraction) type(t_model), intent(in) :: model - t_vec3, intent(in) :: point - t_vec3, intent(in) :: spacing - integer, intent(in) :: spc + t_vec3, intent(in) :: point + t_vec3, intent(in) :: spacing + integer, intent(in) :: spc real(kind(0d0)) :: fraction type(t_ray) :: ray - integer :: i, j, nInOrOut, nHits + integer :: i, j, nInOrOut, nHits real(kind(0d0)), dimension(1:spc, 1:3) :: ray_origins, ray_dirs - + do i = 1, spc - call random_number(ray_origins(i,:)) - ray_origins(i,:) = point + (ray_origins(i,:) - 0.5) * spacing(:) + call random_number(ray_origins(i, :)) + ray_origins(i, :) = point + (ray_origins(i, :) - 0.5)*spacing(:) - call random_number(ray_dirs(i,:)) - ray_dirs(i,:) = ray_dirs(i,:) - 0.5 - ray_dirs(i,:) = ray_dirs(i,:) / sqrt(sum(ray_dirs(i,:) * ray_dirs(i,:))) + call random_number(ray_dirs(i, :)) + ray_dirs(i, :) = ray_dirs(i, :) - 0.5 + ray_dirs(i, :) = ray_dirs(i, :)/sqrt(sum(ray_dirs(i, :)*ray_dirs(i, :))) end do nInOrOut = 0 do i = 1, spc - ray%o = ray_origins(i,:) - ray%d = ray_dirs(i,:) + ray%o = ray_origins(i, :) + ray%d = ray_dirs(i, :) nHits = 0 do j = 1, model%ntrs @@ -473,7 +473,7 @@ contains nInOrOut = nInOrOut + mod(nHits, 2) end do - fraction = real(nInOrOut) / real(spc) + fraction = real(nInOrOut)/real(spc) end function f_model_is_inside @@ -484,7 +484,7 @@ contains !! @return True if the ray intersects the triangle, false otherwise. function f_intersects_triangle(ray, triangle) result(intersects) - type(t_ray), intent(in) :: ray + type(t_ray), intent(in) :: ray type(t_triangle), intent(in) :: triangle logical :: intersects @@ -494,47 +494,47 @@ contains intersects = .false. - N = triangle%n - area2 = sqrt(sum(N(:) * N(:))) - - NdotRayDirection = sum(N(:) * ray%d(:)) + N = triangle%n + area2 = sqrt(sum(N(:)*N(:))) - if (abs(NdotRayDirection) .lt. 0.0000001) then + NdotRayDirection = sum(N(:)*ray%d(:)) + + if (abs(NdotRayDirection) < 0.0000001) then return end if - d = - sum(N(:) * triangle%v(1,:)) - t = - (sum(N(:) * ray%o(:)) + d) / NdotRayDirection - - if (t .lt. 0) then + d = -sum(N(:)*triangle%v(1, :)) + t = -(sum(N(:)*ray%o(:)) + d)/NdotRayDirection + + if (t < 0) then return end if - P = ray%o + t * ray%d + P = ray%o + t*ray%d - edge = triangle%v(2,:) - triangle%v(1,:) - vp = P - triangle%v(1,:) + edge = triangle%v(2, :) - triangle%v(1, :) + vp = P - triangle%v(1, :) C = f_cross(edge, vp) - if (sum(N(:) * C(:)) .lt. 0) then + if (sum(N(:)*C(:)) < 0) then return end if - edge = triangle%v(3,:) - triangle%v(2,:) - vp = P - triangle%v(2,:) + edge = triangle%v(3, :) - triangle%v(2, :) + vp = P - triangle%v(2, :) C = f_cross(edge, vp) - if (sum(N(:) * C(:)) .lt. 0) then + if (sum(N(:)*C(:)) < 0) then return end if - edge = triangle%v(1,:) - triangle%v(3,:) - vp = P - triangle%v(3,:) + edge = triangle%v(1, :) - triangle%v(3, :) + vp = P - triangle%v(3, :) C = f_cross(edge, vp) - if (sum(N(:) * C(:)) .lt. 0) then + if (sum(N(:)*C(:)) < 0) then return end if intersects = .true. - + end function f_intersects_triangle end module m_model diff --git a/src/pre_process/m_mpi_proxy.fpp b/src/pre_process/m_mpi_proxy.fpp index b8a091029..b0e9ff225 100644 --- a/src/pre_process/m_mpi_proxy.fpp +++ b/src/pre_process/m_mpi_proxy.fpp @@ -28,7 +28,6 @@ module m_mpi_proxy contains - !> Since only processor with rank 0 is in charge of reading !! and checking the consistency of the user provided inputs, !! these are not available to the remaining processors. This @@ -46,7 +45,7 @@ contains #:for VAR in ['t_step_old', 'm', 'n', 'p', 'm_glb', 'n_glb', 'p_glb', & & 'loops_x', 'loops_y', 'loops_z', 'model_eqns', 'num_fluids', & - & 'weno_order', 'precision', 'perturb_flow_fluid', & + & 'weno_order', 'precision', 'perturb_flow_fluid', & & 'perturb_sph_fluid', 'num_patches', 'thermal', 'nb', 'dist_type',& & 'R0_type', 'relax_model' ] call MPI_BCAST(${VAR}$, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) @@ -60,7 +59,6 @@ contains #:endfor call MPI_BCAST(fluid_rho(1), num_fluids_max, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) - #:for VAR in [ 'x_domain%beg', 'x_domain%end', 'y_domain%beg', & & 'y_domain%end', 'z_domain%beg', 'z_domain%end', 'a_x', 'a_y', & & 'a_z', 'x_a', 'x_b', 'y_a', 'y_b', 'z_a', 'z_b', 'bc_x%beg', & @@ -75,7 +73,7 @@ contains #:for VAR in [ 'geometry', 'smooth_patch_id'] call MPI_BCAST(patch_icpp(i)%${VAR}$, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) #:endfor - + call MPI_BCAST(patch_icpp(i)%smoothen, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST(patch_icpp(i)%alter_patch(0), num_patches_max, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) @@ -89,7 +87,7 @@ contains call MPI_BCAST(patch_icpp(i)%model%filepath, len(patch_icpp(i)%model%filepath), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) #:for VAR in [ 'model%translate', 'model%scale', 'model%rotate', & - 'normal', 'radii', 'vel', 'tau_e', 'alpha_rho', 'alpha' ] + 'normal', 'radii', 'vel', 'tau_e', 'alpha_rho', 'alpha' ] call MPI_BCAST(patch_icpp(i)%${VAR}$, size(patch_icpp(i)%${VAR}$), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) #:endfor @@ -98,7 +96,7 @@ contains ! Fluids physical parameters do i = 1, num_fluids_max - #:for VAR in [ 'gamma','pi_inf','mul0','ss','pv','gamma_v','M_v', & + #:for VAR in [ 'gamma','pi_inf','mul0','ss','pv','gamma_v','M_v', & & 'mu_v','k_v', 'G', 'qv' ] call MPI_BCAST(fluid_pp(i)%${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) #:endfor @@ -107,7 +105,6 @@ contains end subroutine s_mpi_bcast_user_inputs ! ------------------------------- - !> Description: This subroutine takes care of efficiently distributing !! the computational domain among the available processors !! as well as recomputing some of the global parameters so diff --git a/src/pre_process/m_patches.fpp b/src/pre_process/m_patches.fpp index 2f7329357..f3c924af2 100644 --- a/src/pre_process/m_patches.fpp +++ b/src/pre_process/m_patches.fpp @@ -29,26 +29,25 @@ module m_patches implicit none private; public :: s_line_segment, & - s_spiral, & - s_circle, & - s_varcircle, & - s_3dvarcircle, & - s_ellipse, & - s_ellipsoid, & - s_rectangle, & - s_sweep_line, & - s_2D_TaylorGreen_vortex, & - s_1D_analytical, & - s_1d_bubble_pulse, & - s_2D_analytical, & - s_3D_analytical, & - s_spherical_harmonic, & - s_sphere, & - s_cuboid, & - s_cylinder, & - s_sweep_plane, & - s_model - + s_spiral, & + s_circle, & + s_varcircle, & + s_3dvarcircle, & + s_ellipse, & + s_ellipsoid, & + s_rectangle, & + s_sweep_line, & + s_2D_TaylorGreen_vortex, & + s_1D_analytical, & + s_1d_bubble_pulse, & + s_2D_analytical, & + s_3D_analytical, & + s_spherical_harmonic, & + s_sphere, & + s_cuboid, & + s_cylinder, & + s_sweep_plane, & + s_model real(kind(0d0)) :: x_centroid, y_centroid, z_centroid real(kind(0d0)) :: length_x, length_y, length_z @@ -126,7 +125,7 @@ contains patch_icpp(patch_id)%alter_patch(patch_id_fp(i, 0, 0))) then call s_assign_patch_primitive_variables(patch_id, i, 0, 0, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) @:analytical() end if @@ -157,7 +156,7 @@ contains thickness = patch_icpp(patch_id)%length_x nturns = patch_icpp(patch_id)%length_y - ! + ! logic_grid = 0 do k = 0, int(m*91*nturns) th = k/real(int(m*91d0*nturns))*nturns*2.d0*pi @@ -184,7 +183,7 @@ contains do i = 0, m if ((logic_grid(i, j, 0) == 1)) then call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) @:analytical() end if @@ -231,22 +230,22 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, dy)* & - (sqrt((x_cc(i) - x_centroid)**2 & - + (y_cc(j) - y_centroid)**2) & + (sqrt((x_cc(i) - x_centroid)**2 & + + (y_cc(j) - y_centroid)**2) & - radius))*(-0.5d0) + 0.5d0 end if if (((x_cc(i) - x_centroid)**2 & - + (y_cc(j) - y_centroid)**2 <= radius**2 & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & + + (y_cc(j) - y_centroid)**2 <= radius**2 & + .and. & + patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & .or. & patch_id_fp(i, j, 0) == smooth_patch_id) & then call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) - + eta, q_prim_vf, patch_id_fp) + @:analytical() end if @@ -299,12 +298,12 @@ contains patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) then call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) @:analytical() q_prim_vf(alf_idx)%sf(i, j, 0) = patch_icpp(patch_id)%alpha(1)* & - dexp(-0.5d0*((myr - radius)**2.d0)/(thickness/3.d0)**2.d0) + dexp(-0.5d0*((myr - radius)**2.d0)/(thickness/3.d0)**2.d0) end if end do @@ -358,12 +357,12 @@ contains patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) then call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) - + eta, q_prim_vf, patch_id_fp) + @:analytical() q_prim_vf(alf_idx)%sf(i, j, k) = patch_icpp(patch_id)%alpha(1)* & - dexp(-0.5d0*((myr - radius)**2.d0)/(thickness/3.d0)**2.d0) + dexp(-0.5d0*((myr - radius)**2.d0)/(thickness/3.d0)**2.d0) end if end do @@ -410,22 +409,22 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, dy)* & - (sqrt(((x_cc(i) - x_centroid)/a)**2 + & - ((y_cc(j) - y_centroid)/b)**2) & + (sqrt(((x_cc(i) - x_centroid)/a)**2 + & + ((y_cc(j) - y_centroid)/b)**2) & - 1d0))*(-0.5d0) + 0.5d0 end if if ((((x_cc(i) - x_centroid)/a)**2 + & - ((y_cc(j) - y_centroid)/b)**2 <= 1d0 & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & + ((y_cc(j) - y_centroid)/b)**2 <= 1d0 & + .and. & + patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & .or. & patch_id_fp(i, j, 0) == smooth_patch_id) & then call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) - + eta, q_prim_vf, patch_id_fp) + @:analytical() end if end do @@ -483,24 +482,24 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, dy, dz)* & - (sqrt(((x_cc(i) - x_centroid)/a)**2 + & - ((cart_y - y_centroid)/b)**2 + & - ((cart_z - z_centroid)/c)**2) & + (sqrt(((x_cc(i) - x_centroid)/a)**2 + & + ((cart_y - y_centroid)/b)**2 + & + ((cart_z - z_centroid)/c)**2) & - 1d0))*(-0.5d0) + 0.5d0 end if if ((((x_cc(i) - x_centroid)/a)**2 + & - ((cart_y - y_centroid)/b)**2 + & - ((cart_z - z_centroid)/c)**2 <= 1d0 & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & + ((cart_y - y_centroid)/b)**2 + & + ((cart_z - z_centroid)/c)**2 <= 1d0 & + .and. & + patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & .or. & patch_id_fp(i, j, k) == smooth_patch_id) & then call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) - + eta, q_prim_vf, patch_id_fp) + @:analytical() end if end do @@ -527,7 +526,7 @@ contains real(kind(0d0)) :: pi_inf, gamma, lit_gamma !< Equation of state parameters integer :: i, j, k !< generic loop iterators - + pi_inf = fluid_pp(1)%pi_inf gamma = fluid_pp(1)%gamma lit_gamma = (1d0 + gamma)/gamma @@ -566,7 +565,7 @@ contains then call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) @:analytical() @@ -624,19 +623,19 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = 5d-1 + 5d-1*tanh(smooth_coeff/min(dx, dy) & - *(a*x_cc(i) + b*y_cc(j) + c) & - /sqrt(a**2 + b**2)) + *(a*x_cc(i) + b*y_cc(j) + c) & + /sqrt(a**2 + b**2)) end if if ((a*x_cc(i) + b*y_cc(j) + c >= 0d0 & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & + .and. & + patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & .or. & patch_id_fp(i, j, 0) == smooth_patch_id) & then call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) - + eta, q_prim_vf, patch_id_fp) + @:analytical() end if @@ -684,7 +683,7 @@ contains ! state in the cells that this patch covers. eta = 1d0 ! U0 is the characteristic velocity of the vortex - U0 = patch_icpp(patch_id)%vel(1) + U0 = patch_icpp(patch_id)%vel(1) ! L0 is the characteristic length of the vortex L0 = patch_icpp(patch_id)%vel(2) ! Checking whether the patch covers a particular cell in the @@ -701,16 +700,16 @@ contains patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) then call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) @:analytical() ! Assign Parameters ========================================================= - q_prim_vf(mom_idx%beg )%sf(i,j,0) = U0*SIN(x_cc(i)/L0)*COS(y_cc(j)/L0) - q_prim_vf(mom_idx%end )%sf(i,j,0) = -U0*COS(x_cc(i)/L0)*SIN(y_cc(j)/L0) - q_prim_vf(E_idx )%sf(i,j,0) = patch_icpp(patch_id)%pres + (COS(2*x_cc(i))/L0 + & - COS(2*y_cc(j))/L0)* & - (q_prim_vf(1)%sf(i,j,0)*U0*U0)/16 + q_prim_vf(mom_idx%beg)%sf(i, j, 0) = U0*sin(x_cc(i)/L0)*cos(y_cc(j)/L0) + q_prim_vf(mom_idx%end)%sf(i, j, 0) = -U0*cos(x_cc(i)/L0)*sin(y_cc(j)/L0) + q_prim_vf(E_idx)%sf(i, j, 0) = patch_icpp(patch_id)%pres + (cos(2*x_cc(i))/L0 + & + cos(2*y_cc(j))/L0)* & + (q_prim_vf(1)%sf(i, j, 0)*U0*U0)/16 ! ================================================================================ end if @@ -766,7 +765,7 @@ contains patch_icpp(patch_id)%alter_patch(patch_id_fp(i, 0, 0))) then call s_assign_patch_primitive_variables(patch_id, i, 0, 0, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) @:Hardcoded1D() end if @@ -818,10 +817,10 @@ contains patch_icpp(patch_id)%alter_patch(patch_id_fp(i, 0, 0))) then call s_assign_patch_primitive_variables(patch_id, i, 0, 0, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) @:analytical() - + end if end do @@ -883,7 +882,7 @@ contains patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) then call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) @:Hardcoded2D() end if @@ -959,7 +958,7 @@ contains then call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) @:Hardcoded3D() @@ -1018,10 +1017,10 @@ contains end if if (((x_cc(i) - x_centroid)**2 & - + (cart_y - y_centroid)**2 & - + (cart_z - z_centroid)**2 <= radius**2 & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k)))) & + + (cart_y - y_centroid)**2 & + + (cart_z - z_centroid)**2 <= radius**2 & + .and. & + patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k)))) & then call s_convert_cylindrical_to_spherical_coord(x_cc(i), y_cc(j)) @@ -1055,7 +1054,7 @@ contains elseif (epsilon == 4d0) then if (beta == 0d0) then H = 3d0/16d0*sqrt(1d0/pi)*(35d0*cos(sph_phi)**4d0 - & - 3d1*cos(sph_phi)**2 + 3d0) + 3d1*cos(sph_phi)**2 + 3d0) elseif (beta == 1d0) then H = -3d0/8d0*sqrt(5d0/pi)*exp(cmplx_i*z_cc(k))* & sin(sph_phi)*(7d0*cos(sph_phi)**3d0 - 3d0*cos(sph_phi)) @@ -1153,26 +1152,25 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, dy, dz)* & - (sqrt((x_cc(i) - x_centroid)**2 & - + (cart_y - y_centroid)**2 & - + (cart_z - z_centroid)**2) & + (sqrt((x_cc(i) - x_centroid)**2 & + + (cart_y - y_centroid)**2 & + + (cart_z - z_centroid)**2) & - radius))*(-0.5d0) + 0.5d0 end if if (((x_cc(i) - x_centroid)**2 & - + (cart_y - y_centroid)**2 & - + (cart_z - z_centroid)**2 <= radius**2 & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & + + (cart_y - y_centroid)**2 & + + (cart_z - z_centroid)**2 <= radius**2 & + .and. & + patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & .or. & patch_id_fp(i, j, k) == smooth_patch_id) & then call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) + eta, q_prim_vf, patch_id_fp) - @:analytical() end if @@ -1248,8 +1246,8 @@ contains then call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) - + eta, q_prim_vf, patch_id_fp) + @:analytical() end if @@ -1322,49 +1320,49 @@ contains if (length_x /= dflt_real) then eta = tanh(smooth_coeff/min(dy, dz)* & - (sqrt((cart_y - y_centroid)**2 & - + (cart_z - z_centroid)**2) & + (sqrt((cart_y - y_centroid)**2 & + + (cart_z - z_centroid)**2) & - radius))*(-0.5d0) + 0.5d0 elseif (length_y /= dflt_real) then eta = tanh(smooth_coeff/min(dx, dz)* & - (sqrt((x_cc(i) - x_centroid)**2 & - + (cart_z - z_centroid)**2) & + (sqrt((x_cc(i) - x_centroid)**2 & + + (cart_z - z_centroid)**2) & - radius))*(-0.5d0) + 0.5d0 else eta = tanh(smooth_coeff/min(dx, dy)* & - (sqrt((x_cc(i) - x_centroid)**2 & - + (cart_y - y_centroid)**2) & + (sqrt((x_cc(i) - x_centroid)**2 & + + (cart_y - y_centroid)**2) & - radius))*(-0.5d0) + 0.5d0 end if end if if ((((length_x /= dflt_real .and. & - (cart_y - y_centroid)**2 & - + (cart_z - z_centroid)**2 <= radius**2 .and. & - x_boundary%beg <= x_cc(i) .and. & - x_boundary%end >= x_cc(i)) & - .or. & - (length_y /= dflt_real .and. & - (x_cc(i) - x_centroid)**2 & - + (cart_z - z_centroid)**2 <= radius**2 .and. & - y_boundary%beg <= cart_y .and. & - y_boundary%end >= cart_y) & - .or. & - (length_z /= dflt_real .and. & - (x_cc(i) - x_centroid)**2 & - + (cart_y - y_centroid)**2 <= radius**2 .and. & - z_boundary%beg <= cart_z .and. & - z_boundary%end >= cart_z)) & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & + (cart_y - y_centroid)**2 & + + (cart_z - z_centroid)**2 <= radius**2 .and. & + x_boundary%beg <= x_cc(i) .and. & + x_boundary%end >= x_cc(i)) & + .or. & + (length_y /= dflt_real .and. & + (x_cc(i) - x_centroid)**2 & + + (cart_z - z_centroid)**2 <= radius**2 .and. & + y_boundary%beg <= cart_y .and. & + y_boundary%end >= cart_y) & + .or. & + (length_z /= dflt_real .and. & + (x_cc(i) - x_centroid)**2 & + + (cart_y - y_centroid)**2 <= radius**2 .and. & + z_boundary%beg <= cart_z .and. & + z_boundary%end >= cart_z)) & + .and. & + patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & .or. & patch_id_fp(i, j, k) == smooth_patch_id) & then call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) - + eta, q_prim_vf, patch_id_fp) + @:analytical() end if @@ -1427,22 +1425,22 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = 5d-1 + 5d-1*tanh(smooth_coeff/min(dx, dy, dz) & - *(a*x_cc(i) + & - b*cart_y + & - c*cart_z + d) & - /sqrt(a**2 + b**2 + c**2)) + *(a*x_cc(i) + & + b*cart_y + & + c*cart_z + d) & + /sqrt(a**2 + b**2 + c**2)) end if if ((a*x_cc(i) + b*cart_y + c*cart_z + d >= 0d0 & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & + .and. & + patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & .or. & patch_id_fp(i, j, k) == smooth_patch_id) & then call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) - + eta, q_prim_vf, patch_id_fp) + @:analytical() end if @@ -1457,9 +1455,9 @@ contains !! @param patch_id is the patch identifier subroutine s_model(patch_id, patch_id_fp, q_prim_vf) ! --------------------- - integer, intent(IN) :: patch_id + integer, intent(IN) :: patch_id integer, intent(INOUT), dimension(0:m, 0:n, 0:p) :: patch_id_fp - type(scalar_field), dimension(1:sys_size) :: q_prim_vf + type(scalar_field), dimension(1:sys_size) :: q_prim_vf integer :: i, j, k !< Generic loop iterators @@ -1477,12 +1475,12 @@ contains t_mat4x4 :: transform if (proc_rank == 0) then - print*, " * Reading model: " // trim(patch_icpp(patch_id)%model%filepath) + print *, " * Reading model: "//trim(patch_icpp(patch_id)%model%filepath) end if model = f_model_read(patch_icpp(patch_id)%model%filepath) if (proc_rank == 0) then - print*, " * Transforming model..." + print *, " * Transforming model..." end if transform = f_create_transform_matrix(patch_icpp(patch_id)%model) call s_transform_model(model, transform) @@ -1490,60 +1488,60 @@ contains bbox = f_create_bbox(model) if (proc_rank == 0) then - write (*,"(A, 3(2X, F20.10))") " > Model: Min:", bbox%min(1:3) - write (*,"(A, 3(2X, F20.10))") " > Cen:", (bbox%min(1:3) + bbox%max(1:3))/2d0 - write (*,"(A, 3(2X, F20.10))") " > Max:", bbox%max(1:3) + write (*, "(A, 3(2X, F20.10))") " > Model: Min:", bbox%min(1:3) + write (*, "(A, 3(2X, F20.10))") " > Cen:", (bbox%min(1:3) + bbox%max(1:3))/2d0 + write (*, "(A, 3(2X, F20.10))") " > Max:", bbox%max(1:3) !call s_model_write("__out__.stl", model) !call s_model_write("__out__.obj", model) - grid_mm(1,:) = (/ minval(x_cc) - 0d5 * dx, maxval(x_cc) + 0d5 * dx /) - grid_mm(2,:) = (/ minval(y_cc) - 0d5 * dy, maxval(y_cc) + 0d5 * dy /) - - if (p .gt. 0) then - grid_mm(3,:) = (/ minval(z_cc) - 0d5 * dz, maxval(z_cc) + 0d5 * dz /) + grid_mm(1, :) = (/minval(x_cc) - 0d5*dx, maxval(x_cc) + 0d5*dx/) + grid_mm(2, :) = (/minval(y_cc) - 0d5*dy, maxval(y_cc) + 0d5*dy/) + + if (p > 0) then + grid_mm(3, :) = (/minval(z_cc) - 0d5*dz, maxval(z_cc) + 0d5*dz/) else - grid_mm(3,:) = (/ 0d0, 0d0 /) + grid_mm(3, :) = (/0d0, 0d0/) end if - write (*,"(A, 3(2X, F20.10))") " > Domain: Min:", grid_mm(:,1) - write (*,"(A, 3(2X, F20.10))") " > Cen:", (grid_mm(:,1) + grid_mm(:,2))/2d0 - write (*,"(A, 3(2X, F20.10))") " > Max:", grid_mm(:,2) + write (*, "(A, 3(2X, F20.10))") " > Domain: Min:", grid_mm(:, 1) + write (*, "(A, 3(2X, F20.10))") " > Cen:", (grid_mm(:, 1) + grid_mm(:, 2))/2d0 + write (*, "(A, 3(2X, F20.10))") " > Max:", grid_mm(:, 2) end if - ncells = (m+1)*(n+1)*(p+1) + ncells = (m + 1)*(n + 1)*(p + 1) do i = 0, m; do j = 0, n; do k = 0, p - cell_num = i*(n+1)*(p+1) + j*(p+1) + (k+1) - if (proc_rank == 0 .and. mod(cell_num, ncells / 100) == 0) then - write (*,"(A, I3, A)", advance="no") & - CHAR(13) // " * Generating grid: ", & - NINT(100 * real(cell_num) / ncells), "%" - end if + cell_num = i*(n + 1)*(p + 1) + j*(p + 1) + (k + 1) + if (proc_rank == 0 .and. mod(cell_num, ncells/100) == 0) then + write (*, "(A, I3, A)", advance="no") & + char(13)//" * Generating grid: ", & + nint(100*real(cell_num)/ncells), "%" + end if - point = (/ x_cc(i), y_cc(j), 0d0 /) - if (p .gt. 0) then - point(3) = z_cc(k) - end if + point = (/x_cc(i), y_cc(j), 0d0/) + if (p > 0) then + point(3) = z_cc(k) + end if - if (grid_geometry == 3) then - point = f_convert_cyl_to_cart(point) - end if + if (grid_geometry == 3) then + point = f_convert_cyl_to_cart(point) + end if - eta = f_model_is_inside(model, point, (/ dx, dy, dz /), patch_icpp(patch_id)%model%spc) - - call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) + eta = f_model_is_inside(model, point, (/dx, dy, dz/), patch_icpp(patch_id)%model%spc) - ! Note: Should probably use *eta* to compute primitive variables - ! if defining them analytically. - @:analytical() + call s_assign_patch_primitive_variables(patch_id, i, j, k, & + eta, q_prim_vf, patch_id_fp) + + ! Note: Should probably use *eta* to compute primitive variables + ! if defining them analytically. + @:analytical() - end do; end do; end do + end do; end do; end do if (proc_rank == 0) then - print*, "" - print*, " * Cleaning up..." + print *, "" + print *, " * Cleaning up..." end if call s_model_free(model) @@ -1564,12 +1562,12 @@ contains !$acc routine seq - t_vec3, intent(in) :: cyl + t_vec3, intent(in) :: cyl t_vec3 :: cart - cart = (/ cyl(1), & - cyl(2)*sin(cyl(3)), & - cyl(2)*cos(cyl(3)) /) + cart = (/cyl(1), & + cyl(2)*sin(cyl(3)), & + cyl(2)*cos(cyl(3))/) end function f_convert_cyl_to_cart diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index 452dfb994..9cf3ae463 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -4,8 +4,8 @@ !> @brief This module contains subroutines that read, and check consistency !! of, the user provided inputs, grid and data. This module also allocates -!! and initializes the relevant variables sets up the mpi decomposition and -!! initial condition procedures. +!! and initializes the relevant variables sets up the mpi decomposition and +!! initial condition procedures. module m_start_up ! Dependencies ============================================================= @@ -47,19 +47,19 @@ module m_start_up implicit none private; public :: s_read_input_file, & - s_check_input_file, & - s_read_grid_data_files, & - s_read_ic_data_files, & - s_read_serial_grid_data_files, & - s_read_serial_ic_data_files, & - s_read_parallel_grid_data_files, & - s_read_parallel_ic_data_files, & - s_check_grid_data_files, & - s_initialize_modules, & - s_initialize_mpi_domain, & - s_finalize_modules, & - s_apply_initial_condition, & - s_save_data, s_read_grid + s_check_input_file, & + s_read_grid_data_files, & + s_read_ic_data_files, & + s_read_serial_grid_data_files, & + s_read_serial_ic_data_files, & + s_read_parallel_grid_data_files, & + s_read_parallel_ic_data_files, & + s_check_grid_data_files, & + s_initialize_modules, & + s_initialize_mpi_domain, & + s_finalize_modules, & + s_apply_initial_condition, & + s_save_data, s_read_grid abstract interface ! =================================================== @@ -140,11 +140,11 @@ contains STATUS='old', ACTION='read') read (1, NML=user_inputs, iostat=iostatus) if (iostatus /= 0) then - backspace(1) - read(1,fmt='(A)') line - print*, 'Invalid line in namelist: '//trim(line) + backspace (1) + read (1, fmt='(A)') line + print *, 'Invalid line in namelist: '//trim(line) call s_mpi_abort('Invalid line in pre_process.inp. It is '// & - 'likely due to a datatype mismatch. Exiting ...') + 'likely due to a datatype mismatch. Exiting ...') end if close (1) ! Store m,n,p into global m,n,p @@ -179,8 +179,8 @@ contains if (dir_check .neqv. .true.) then print '(A)', 'WARNING: Ensure that compiler flags/choices in Makefiles match your compiler! ' print '(A)', 'WARNING: Ensure that preprocessor flags are enabled! ' - call s_mpi_abort('Unsupported choice for the value of case_dir.' // & - 'Exiting ...') + call s_mpi_abort('Unsupported choice for the value of case_dir.'// & + 'Exiting ...') end if call s_check_inputs() @@ -219,7 +219,7 @@ contains ! If the time-step directory is missing, the pre-process exits if (dir_check .neqv. .true.) then call s_mpi_abort('Time-step folder '//trim(t_step_dir)// & - ' is missing. Exiting ...') + ' is missing. Exiting ...') end if ! Reading the Grid Data File for the x-direction =================== @@ -234,9 +234,9 @@ contains STATUS='old', ACTION='read') read (1) x_cb(-1:m) close (1) - else + else call s_mpi_abort('File x_cb.dat is missing in '// & - trim(t_step_dir)//'. Exiting ...') + trim(t_step_dir)//'. Exiting ...') end if ! Computing cell-center locations @@ -268,7 +268,7 @@ contains close (1) else call s_mpi_abort('File y_cb.dat is missing in '// & - trim(t_step_dir)//'. Exiting ...') + trim(t_step_dir)//'. Exiting ...') end if ! Computing cell-center locations @@ -300,7 +300,7 @@ contains close (1) else call s_mpi_abort('File z_cb.dat is missing in '// & - trim(t_step_dir)//'. Exiting ...') + trim(t_step_dir)//'. Exiting ...') end if ! Computing cell-center locations @@ -343,7 +343,7 @@ contains if (any(x_cb(0:m) - x_cb(-1:m - 1) <= 0d0)) then call s_mpi_abort('x_cb.dat in '//trim(t_step_dir)// & - ' contains non-positive cell-spacings. Exiting ...') + ' contains non-positive cell-spacings. Exiting ...') end if ! ================================================================== @@ -354,8 +354,8 @@ contains if (any(y_cb(0:n) - y_cb(-1:n - 1) <= 0d0)) then call s_mpi_abort('y_cb.dat in '//trim(t_step_dir)// & - ' contains non-positive cell-spacings. '// & - 'Exiting ...') + ' contains non-positive cell-spacings. '// & + 'Exiting ...') end if ! ================================================================== @@ -366,8 +366,8 @@ contains if (any(z_cb(0:p) - z_cb(-1:p - 1) <= 0d0)) then call s_mpi_abort('z_cb.dat in '//trim(t_step_dir)// & - ' contains non-positive cell-spacings'// & - ' .Exiting ...') + ' contains non-positive cell-spacings'// & + ' .Exiting ...') end if end if @@ -420,20 +420,20 @@ contains read (1) q_cons_vf(i)%sf close (1) else - call s_mpi_abort( 'File q_cons_vf'//trim(file_num)// & - '.dat is missing in '//trim(t_step_dir)// & - '. Exiting ...') + call s_mpi_abort('File q_cons_vf'//trim(file_num)// & + '.dat is missing in '//trim(t_step_dir)// & + '. Exiting ...') end if end do !Read bubble variables pb and mv for non-polytropic qbmm - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode ! Checking whether data file associated with variable position ! of the currently manipulated bubble variable exists - write (file_num, '(I0)') sys_size + r + (i-1)*nnode + write (file_num, '(I0)') sys_size + r + (i - 1)*nnode file_loc = trim(t_step_dir)//'/pb'// & trim(file_num)//'.dat' inquire (FILE=trim(file_loc), EXIST=file_check) @@ -445,9 +445,9 @@ contains read (1) pb%sf(:, :, :, r, i) close (1) else - call s_mpi_abort( 'File pb'//trim(file_num)// & - '.dat is missing in '//trim(t_step_dir)// & - '. Exiting ...') + call s_mpi_abort('File pb'//trim(file_num)// & + '.dat is missing in '//trim(t_step_dir)// & + '. Exiting ...') end if end do @@ -457,7 +457,7 @@ contains do r = 1, 4 ! Checking whether data file associated with variable position ! of the currently manipulated bubble variable exists - write (file_num, '(I0)') sys_size + r + (i-1)*4 + write (file_num, '(I0)') sys_size + r + (i - 1)*4 file_loc = trim(t_step_dir)//'/mv'// & trim(file_num)//'.dat' inquire (FILE=trim(file_loc), EXIST=file_check) @@ -469,9 +469,9 @@ contains read (1) mv%sf(:, :, :, r, i) close (1) else - call s_mpi_abort( 'File mv'//trim(file_num)// & - '.dat is missing in '//trim(t_step_dir)// & - '. Exiting ...') + call s_mpi_abort('File mv'//trim(file_num)// & + '.dat is missing in '//trim(t_step_dir)// & + '. Exiting ...') end if end do @@ -655,7 +655,7 @@ contains MPI_DOUBLE_PRECISION, status, ierr) end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*4 var_MOK = int(i, MPI_OFFSET_KIND) @@ -669,7 +669,6 @@ contains end do end if - call s_mpi_barrier() call MPI_FILE_CLOSE(ifile, ierr) @@ -688,18 +687,18 @@ contains ! needed to properly setup the modules call s_initialize_global_parameters_module() !Quadrature weights and nodes for polydisperse simulations - if(bubbles .and. nb > 1) then + if (bubbles .and. nb > 1) then call s_simpson end if !Initialize variables for non-polytropic (Preston) model - if(bubbles .and. .not. polytropic) then + if (bubbles .and. .not. polytropic) then call s_initialize_nonpoly() end if !Initialize pb based on surface tension for qbmm (polytropic) - if(qbmm .and. polytropic .and. Web /= dflt_real) then - pb0 = pref + 2d0 * fluid_pp(1)%ss / (R0*R0ref) - pb0 = pb0 / pref - pref = 1d0 + if (qbmm .and. polytropic .and. Web /= dflt_real) then + pb0 = pref + 2d0*fluid_pp(1)%ss/(R0*R0ref) + pb0 = pb0/pref + pref = 1d0 end if call s_initialize_data_output_module() call s_initialize_variables_conversion_module() @@ -751,16 +750,16 @@ contains real(kind(0d0)), intent(INOUT) :: start, finish, time_avg, time_final real(kind(0d0)), dimension(:), intent(INOUT) :: proc_time - ! Setting up the grid and the initial condition. If the grid is read in from - ! preexisting grid data files, it is checked for consistency. If the grid is - ! not read in, it is generated from scratch according to the inputs provided - ! by the user. The initial condition may also be read in. It in turn is not - ! checked for consistency since it WILL further be edited by the pre-process - ! and also because it may be incomplete at the time it is read in. Finally, - ! when the grid and initial condition are completely setup, they are written - ! to their respective data files. + ! Setting up the grid and the initial condition. If the grid is read in from + ! preexisting grid data files, it is checked for consistency. If the grid is + ! not read in, it is generated from scratch according to the inputs provided + ! by the user. The initial condition may also be read in. It in turn is not + ! checked for consistency since it WILL further be edited by the pre-process + ! and also because it may be incomplete at the time it is read in. Finally, + ! when the grid and initial condition are completely setup, they are written + ! to their respective data files. - ! Setting up grid and initial condition + ! Setting up grid and initial condition call cpu_time(start) if (old_ic) call s_read_ic_data_files(q_cons_vf) @@ -770,7 +769,7 @@ contains if (relax) then if (proc_rank == 0) then print *, 'initial condition might have been altered due to enforcement of & - pTg-equilirium (relax = "T" activated)' +& pTg-equilirium (relax = "T" activated)' end if call s_relaxation_solver(q_cons_vf) @@ -825,11 +824,11 @@ contains ! leads to the termination of the pre-process. if (proc_rank == 0) then - call s_assign_default_values_to_user_inputs() - call s_read_input_file() - call s_check_input_file() + call s_assign_default_values_to_user_inputs() + call s_read_input_file() + call s_check_input_file() - print '(" Pre-processing a "I0"x"I0"x"I0" case on "I0" rank(s)")', m, n, p, num_procs + print '(" Pre-processing a "I0"x"I0"x"I0" case on "I0" rank(s)")', m, n, p, num_procs end if ! Broadcasting the user inputs to all of the processors and performing the @@ -854,7 +853,6 @@ contains call s_finalize_global_parameters_module() call s_finalize_assign_variables_module() if (relax) call s_finalize_relaxation_solver_module() - ! Finalization of the MPI environment call s_mpi_finalize() diff --git a/src/pre_process/p_main.f90 b/src/pre_process/p_main.f90 index 9908e99a3..544c0311a 100644 --- a/src/pre_process/p_main.f90 +++ b/src/pre_process/p_main.f90 @@ -22,7 +22,7 @@ program p_main real(kind(0d0)), allocatable, dimension(:) :: proc_time call random_seed() - + call s_initialize_mpi_domain() ! Initialization of the MPI environment @@ -39,7 +39,7 @@ program p_main call s_save_data(proc_time, time_avg, time_final, file_exists) - deallocate(proc_time) + deallocate (proc_time) call s_finalize_modules() diff --git a/src/simulation/include/inline_riemann.fpp b/src/simulation/include/inline_riemann.fpp index 5d9ebfb9a..89c332f1c 100644 --- a/src/simulation/include/inline_riemann.fpp +++ b/src/simulation/include/inline_riemann.fpp @@ -9,11 +9,8 @@ H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) - - #:enddef arithmetic_avg - #:def roe_avg() rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = 0d0 @@ -37,13 +34,13 @@ #:def compute_average_state() -if (avg_state == 1) then - @:roe_avg() -end if + if (avg_state == 1) then + @:roe_avg() + end if -if (avg_state == 2) then - @:arithmetic_avg() -end if + if (avg_state == 2) then + @:arithmetic_avg() + end if #:enddef compute_average_state diff --git a/src/simulation/m_boundary_conditions.fpp b/src/simulation/m_boundary_conditions.fpp index 389ebe1b1..5ff77593c 100644 --- a/src/simulation/m_boundary_conditions.fpp +++ b/src/simulation/m_boundary_conditions.fpp @@ -3,7 +3,7 @@ !! @brief Contains module m_boundary_conditions !> @brief The purpose of the module is to apply noncharacteristic and processor -!! boundary condiitons +!! boundary condiitons module m_boundary_conditions ! Dependencies ============================================================= @@ -20,7 +20,7 @@ module m_boundary_conditions private; public :: s_populate_conservative_variables_buffers - contains +contains !> The purpose of this procedure is to populate the buffers !! of the conservative variables, depending on the selected @@ -28,41 +28,41 @@ module m_boundary_conditions subroutine s_populate_conservative_variables_buffers(q_cons_vf, pb, mv) type(scalar_field), dimension(sys_size) :: q_cons_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: pb, mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: pb, mv integer :: bc_loc, bc_dir ! Population of Buffers in x-direction ============================= - select case(bc_x%beg) - case(-13:-3) ! Ghost-cell extrap. BC at beginning - call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 1, -1) - case(-2) ! Symmetry BC at beginning - call s_symmetry(q_cons_vf, pb, mv, 1, -1) - case(-1) ! Periodic BC at beginning - call s_periodic(q_cons_vf, pb, mv, 1, -1) - case(-15) ! Slip wall BC at beginning - call s_slip_wall(q_cons_vf, pb, mv, 1, -1) - case(-16) ! No-slip wall BC at beginning - call s_no_slip_wall(q_cons_vf, pb, mv, 1, -1) - case default ! Processor BC at beginning - call s_mpi_sendrecv_conservative_variables_buffers( & - q_cons_vf, pb, mv, 1, -1) + select case (bc_x%beg) + case (-13:-3) ! Ghost-cell extrap. BC at beginning + call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 1, -1) + case (-2) ! Symmetry BC at beginning + call s_symmetry(q_cons_vf, pb, mv, 1, -1) + case (-1) ! Periodic BC at beginning + call s_periodic(q_cons_vf, pb, mv, 1, -1) + case (-15) ! Slip wall BC at beginning + call s_slip_wall(q_cons_vf, pb, mv, 1, -1) + case (-16) ! No-slip wall BC at beginning + call s_no_slip_wall(q_cons_vf, pb, mv, 1, -1) + case default ! Processor BC at beginning + call s_mpi_sendrecv_conservative_variables_buffers( & + q_cons_vf, pb, mv, 1, -1) end select - select case(bc_x%end) - case(-13:-3) ! Ghost-cell extrap. BC at end - call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 1, 1) - case(-2) ! Symmetry BC at end - call s_symmetry(q_cons_vf, pb, mv, 1, 1) - case(-1) ! Periodic BC at end - call s_periodic(q_cons_vf, pb, mv, 1, 1) - case(-15) ! Slip wall BC at end - call s_slip_wall(q_cons_vf, pb, mv, 1, 1) - case(-16) ! No-slip wall bc at end - call s_no_slip_wall(q_cons_vf, pb, mv, 1, 1) - case default ! Processor BC at end - call s_mpi_sendrecv_conservative_variables_buffers( & - q_cons_vf, pb, mv, 1, 1) + select case (bc_x%end) + case (-13:-3) ! Ghost-cell extrap. BC at end + call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 1, 1) + case (-2) ! Symmetry BC at end + call s_symmetry(q_cons_vf, pb, mv, 1, 1) + case (-1) ! Periodic BC at end + call s_periodic(q_cons_vf, pb, mv, 1, 1) + case (-15) ! Slip wall BC at end + call s_slip_wall(q_cons_vf, pb, mv, 1, 1) + case (-16) ! No-slip wall bc at end + call s_no_slip_wall(q_cons_vf, pb, mv, 1, 1) + case default ! Processor BC at end + call s_mpi_sendrecv_conservative_variables_buffers( & + q_cons_vf, pb, mv, 1, 1) end select ! END: Population of Buffers in x-direction ======================== @@ -70,40 +70,39 @@ module m_boundary_conditions ! Population of Buffers in y-direction ============================= if (n == 0) return - - select case(bc_y%beg) - case(-13:-3) ! Ghost-cell extrap. BC at beginning - call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 2, -1) - case(-14) ! Axis BC at beginning - call s_axis(q_cons_vf, pb, mv, 2, -1) - case(-2) ! Symmetry BC at beginning - call s_symmetry(q_cons_vf, pb, mv, 2, -1) - case(-1) ! Periodic BC at beginning - call s_periodic(q_cons_vf, pb, mv, 2, -1) - case(-15) ! Slip wall BC at beginning - call s_slip_wall(q_cons_vf, pb, mv, 2, -1) - case(-16) ! No-slip wall BC at beginning - call s_no_slip_wall(q_cons_vf, pb, mv, 2, -1) - case default ! Processor BC at beginning - call s_mpi_sendrecv_conservative_variables_buffers( & - q_cons_vf, pb, mv, 2, -1) - end select + select case (bc_y%beg) + case (-13:-3) ! Ghost-cell extrap. BC at beginning + call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 2, -1) + case (-14) ! Axis BC at beginning + call s_axis(q_cons_vf, pb, mv, 2, -1) + case (-2) ! Symmetry BC at beginning + call s_symmetry(q_cons_vf, pb, mv, 2, -1) + case (-1) ! Periodic BC at beginning + call s_periodic(q_cons_vf, pb, mv, 2, -1) + case (-15) ! Slip wall BC at beginning + call s_slip_wall(q_cons_vf, pb, mv, 2, -1) + case (-16) ! No-slip wall BC at beginning + call s_no_slip_wall(q_cons_vf, pb, mv, 2, -1) + case default ! Processor BC at beginning + call s_mpi_sendrecv_conservative_variables_buffers( & + q_cons_vf, pb, mv, 2, -1) + end select - select case(bc_y%end) - case(-13:-3) ! Ghost-cell extrap. BC at end - call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 2, 1) - case(-2) ! Symmetry BC at end - call s_symmetry(q_cons_vf, pb, mv, 2, 1) - case(-1) ! Periodic BC at end - call s_periodic(q_cons_vf, pb, mv, 2, 1) - case(-15) ! Slip wall BC at end - call s_slip_wall(q_cons_vf, pb, mv, 2, 1) - case(-16) ! No-slip wall BC at end - call s_no_slip_wall(q_cons_vf, pb, mv, 2, 1) - case default ! Processor BC at end - call s_mpi_sendrecv_conservative_variables_buffers( & - q_cons_vf, pb, mv, 2, 1) + select case (bc_y%end) + case (-13:-3) ! Ghost-cell extrap. BC at end + call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 2, 1) + case (-2) ! Symmetry BC at end + call s_symmetry(q_cons_vf, pb, mv, 2, 1) + case (-1) ! Periodic BC at end + call s_periodic(q_cons_vf, pb, mv, 2, 1) + case (-15) ! Slip wall BC at end + call s_slip_wall(q_cons_vf, pb, mv, 2, 1) + case (-16) ! No-slip wall BC at end + call s_no_slip_wall(q_cons_vf, pb, mv, 2, 1) + case default ! Processor BC at end + call s_mpi_sendrecv_conservative_variables_buffers( & + q_cons_vf, pb, mv, 2, 1) end select ! END: Population of Buffers in y-direction ======================== @@ -112,36 +111,36 @@ module m_boundary_conditions if (p == 0) return - select case(bc_z%beg) - case(-13:-3) ! Ghost-cell extrap. BC at beginning - call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 3, -1) - case(-2) ! Symmetry BC at beginning - call s_symmetry(q_cons_vf, pb, mv, 3, -1) - case(-1) ! Periodic BC at beginning - call s_periodic(q_cons_vf, pb, mv, 3, -1) - case(-15) ! Slip wall BC at beginning - call s_slip_wall(q_cons_vf, pb, mv, 3, -1) - case(-16) ! No-slip wall BC at beginning - call s_no_slip_wall(q_cons_vf, pb, mv, 3, -1) - case default ! Processor BC at beginning - call s_mpi_sendrecv_conservative_variables_buffers( & - q_cons_vf, pb, mv, 3, -1) + select case (bc_z%beg) + case (-13:-3) ! Ghost-cell extrap. BC at beginning + call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 3, -1) + case (-2) ! Symmetry BC at beginning + call s_symmetry(q_cons_vf, pb, mv, 3, -1) + case (-1) ! Periodic BC at beginning + call s_periodic(q_cons_vf, pb, mv, 3, -1) + case (-15) ! Slip wall BC at beginning + call s_slip_wall(q_cons_vf, pb, mv, 3, -1) + case (-16) ! No-slip wall BC at beginning + call s_no_slip_wall(q_cons_vf, pb, mv, 3, -1) + case default ! Processor BC at beginning + call s_mpi_sendrecv_conservative_variables_buffers( & + q_cons_vf, pb, mv, 3, -1) end select - select case(bc_z%end) - case(-13:-3) ! Ghost-cell extrap. BC at end - call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 3, 1) - case(-2) ! Symmetry BC at end - call s_symmetry(q_cons_vf, pb, mv, 3, 1) - case(-1) ! Periodic BC at end - call s_periodic(q_cons_vf, pb, mv, 3, 1) - case(-15) ! Slip wall BC at end - call s_slip_wall(q_cons_vf, pb, mv, 3, 1) - case(-16) ! No-slip wall BC at end - call s_no_slip_wall(q_cons_vf, pb, mv, 3, 1) - case default ! Processor BC at end - call s_mpi_sendrecv_conservative_variables_buffers( & - q_cons_vf, pb, mv, 3, 1) + select case (bc_z%end) + case (-13:-3) ! Ghost-cell extrap. BC at end + call s_ghost_cell_extrapolation(q_cons_vf, pb, mv, 3, 1) + case (-2) ! Symmetry BC at end + call s_symmetry(q_cons_vf, pb, mv, 3, 1) + case (-1) ! Periodic BC at end + call s_periodic(q_cons_vf, pb, mv, 3, 1) + case (-15) ! Slip wall BC at end + call s_slip_wall(q_cons_vf, pb, mv, 3, 1) + case (-16) ! No-slip wall BC at end + call s_no_slip_wall(q_cons_vf, pb, mv, 3, 1) + case default ! Processor BC at end + call s_mpi_sendrecv_conservative_variables_buffers( & + q_cons_vf, pb, mv, 3, 1) end select ! END: Population of Buffers in z-direction ======================== @@ -151,7 +150,7 @@ module m_boundary_conditions subroutine s_ghost_cell_extrapolation(q_cons_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size) :: q_cons_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: pb, mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: pb, mv integer :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -171,8 +170,8 @@ module m_boundary_conditions end do end do end do - - if(qbmm .and. .not. polytropic) then + + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -180,9 +179,9 @@ module m_boundary_conditions do k = 0, n do j = 1, buff_size pb(-j, k, l, q, i) = & - pb(0, k, l, q, i) + pb(0, k, l, q, i) mv(-j, k, l, q, i) = & - mv(0, k, l, q, i) + mv(0, k, l, q, i) end do end do end do @@ -204,7 +203,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -224,7 +223,7 @@ module m_boundary_conditions end if - !< y-direction ========================================================= + !< y-direction ========================================================= elseif (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc_y%beg @@ -241,7 +240,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -273,7 +272,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -281,19 +280,19 @@ module m_boundary_conditions do j = 1, buff_size do l = -buff_size, m + buff_size pb(l, n + j, k, q, i) = & - pb(l, n , k, q, i) + pb(l, n, k, q, i) mv(l, n + j, k, q, i) = & - mv(l, n , k, q, i) + mv(l, n, k, q, i) end do end do end do end do end do - end if + end if end if - !< z-direction ========================================================= + !< z-direction ========================================================= elseif (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc_z%beg @@ -310,7 +309,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -342,23 +341,23 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode do j = 1, buff_size do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size - pb(k, l, p+j, q, i) = & + pb(k, l, p + j, q, i) = & pb(k, l, p, q, i) - mv(k, l, p+j, q, i) = & + mv(k, l, p + j, q, i) = & mv(k, l, p, q, i) end do end do end do end do end do - end if + end if end if @@ -370,7 +369,7 @@ module m_boundary_conditions subroutine s_symmetry(q_cons_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size) :: q_cons_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: pb, mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: pb, mv integer :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -390,7 +389,7 @@ module m_boundary_conditions end do q_cons_vf(momxb)%sf(-j, k, l) = & - - q_cons_vf(momxb)%sf(j - 1, k, l) + -q_cons_vf(momxb)%sf(j - 1, k, l) !$acc loop seq do i = momxb + 1, sys_size @@ -401,7 +400,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -425,27 +424,27 @@ module m_boundary_conditions do l = 0, p do k = 0, n do j = 1, buff_size - + !$acc loop seq do i = 1, contxe q_cons_vf(i)%sf(m + j, k, l) = & q_cons_vf(i)%sf(m - (j - 1), k, l) end do - + q_cons_vf(momxb)%sf(m + j, k, l) = & -q_cons_vf(momxb)%sf(m - (j - 1), k, l) - + !$acc loop seq do i = momxb + 1, sys_size q_cons_vf(i)%sf(m + j, k, l) = & q_cons_vf(i)%sf(m - (j - 1), k, l) end do - + end do end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -465,7 +464,7 @@ module m_boundary_conditions end if - !< y-direction ========================================================= + !< y-direction ========================================================= elseif (bc_dir == 2) then if (bc_loc == -1) then !< bc_y%beg @@ -481,7 +480,7 @@ module m_boundary_conditions end do q_cons_vf(momxb + 1)%sf(l, -j, k) = & - - q_cons_vf(momxb + 1)%sf(l, j - 1, k) + -q_cons_vf(momxb + 1)%sf(l, j - 1, k) !$acc loop seq do i = momxb + 2, sys_size @@ -492,7 +491,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -534,7 +533,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -542,9 +541,9 @@ module m_boundary_conditions do j = 1, buff_size do l = -buff_size, m + buff_size pb(l, n + j, k, q, i) = & - pb(l, n - (j-1), k, q, i) + pb(l, n - (j - 1), k, q, i) mv(l, n + j, k, q, i) = & - mv(l, n - (j-1), k, q, i) + mv(l, n - (j - 1), k, q, i) end do end do end do @@ -553,8 +552,8 @@ module m_boundary_conditions end if end if - - !< z-direction ========================================================= + + !< z-direction ========================================================= elseif (bc_dir == 3) then if (bc_loc == -1) then !< bc_z%beg @@ -581,7 +580,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -589,15 +588,15 @@ module m_boundary_conditions do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size pb(k, l, -j, q, i) = & - pb(k, l, j-1, q, i) + pb(k, l, j - 1, q, i) mv(k, l, -j, q, i) = & - mv(k, l, j-1, q, i) + mv(k, l, j - 1, q, i) end do end do end do end do end do - end if + end if else !< bc_z%end @@ -623,7 +622,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -631,15 +630,15 @@ module m_boundary_conditions do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size pb(k, l, p + j, q, i) = & - pb(k, l, p - (j-1), q, i) - mv(k, l, p + j, q, i) = & - mv(k, l, p - (j-1), q, i) + pb(k, l, p - (j - 1), q, i) + mv(k, l, p + j, q, i) = & + mv(k, l, p - (j - 1), q, i) end do end do end do end do end do - end if + end if end if @@ -651,7 +650,7 @@ module m_boundary_conditions subroutine s_periodic(q_cons_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size) :: q_cons_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: pb, mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: pb, mv integer :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -672,7 +671,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -704,7 +703,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -724,7 +723,7 @@ module m_boundary_conditions end if - !< y-direction ========================================================= + !< y-direction ========================================================= elseif (bc_dir == 2) then if (bc_loc == -1) then !< bc_y%beg @@ -741,7 +740,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(4) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -749,9 +748,9 @@ module m_boundary_conditions do j = 1, buff_size do l = -buff_size, m + buff_size pb(l, -j, k, q, i) = & - pb(l, n - (j-1), k, q, i) + pb(l, n - (j - 1), k, q, i) mv(l, -j, k, q, i) = & - mv(l, n - (j-1), k, q, i) + mv(l, n - (j - 1), k, q, i) end do end do end do @@ -773,7 +772,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -781,9 +780,9 @@ module m_boundary_conditions do j = 1, buff_size do l = -buff_size, m + buff_size pb(l, n + j, k, q, i) = & - pb(l, (j-1), k, q, i) + pb(l, (j - 1), k, q, i) mv(l, n + j, k, q, i) = & - mv(l, (j-1), k, q, i) + mv(l, (j - 1), k, q, i) end do end do end do @@ -792,8 +791,8 @@ module m_boundary_conditions end if end if - - !< z-direction ========================================================= + + !< z-direction ========================================================= elseif (bc_dir == 3) then if (bc_loc == -1) then !< bc_z%beg @@ -810,7 +809,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -818,9 +817,9 @@ module m_boundary_conditions do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size pb(k, l, -j, q, i) = & - pb(k, l, p - (j-1), q, i) + pb(k, l, p - (j - 1), q, i) mv(k, l, -j, q, i) = & - mv(k, l, p - (j-1), q, i) + mv(k, l, p - (j - 1), q, i) end do end do end do @@ -842,7 +841,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -850,15 +849,15 @@ module m_boundary_conditions do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size pb(k, l, p + j, q, i) = & - pb(k, l, j-1, q, i) + pb(k, l, j - 1, q, i) mv(k, l, p + j, q, i) = & - mv(k, l, j-1, q, i) + mv(k, l, j - 1, q, i) end do end do end do end do end do - end if + end if end if @@ -870,7 +869,7 @@ module m_boundary_conditions subroutine s_axis(q_cons_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size) :: q_cons_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: pb, mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: pb, mv integer :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -919,7 +918,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -927,9 +926,9 @@ module m_boundary_conditions do j = 1, buff_size do l = -buff_size, m + buff_size pb(l, -j, k, q, i) = & - pb(l, j-1, k - ((p+1)/2), q, i) + pb(l, j - 1, k - ((p + 1)/2), q, i) mv(l, -j, k, q, i) = & - mv(l, j-1, k - ((p+1)/2), q, i) + mv(l, j - 1, k - ((p + 1)/2), q, i) end do end do end do @@ -942,7 +941,7 @@ module m_boundary_conditions subroutine s_slip_wall(q_cons_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size) :: q_cons_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: pb, mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: pb, mv integer :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -957,7 +956,7 @@ module m_boundary_conditions do k = 0, n do j = 1, buff_size if (i == momxb) then - q_cons_vf(i)%sf(-j,k,l) = & + q_cons_vf(i)%sf(-j, k, l) = & q_cons_vf(i)%sf(j - 1, k, l) else q_cons_vf(i)%sf(-j, k, l) = & @@ -968,7 +967,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(4) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -976,9 +975,9 @@ module m_boundary_conditions do k = 0, n do j = 1, buff_size pb(-j, k, l, q, i) = & - pb(0, k, l, q, i) + pb(0, k, l, q, i) mv(-j, k, l, q, i) = & - mv(0, k, l, q, i) + mv(0, k, l, q, i) end do end do end do @@ -994,10 +993,10 @@ module m_boundary_conditions do k = 0, n do j = 1, buff_size if (i == momxb) then - q_cons_vf(i)%sf(m+j,k,l) = & + q_cons_vf(i)%sf(m + j, k, l) = & -q_cons_vf(i)%sf(m - (j - 1), k, l) else - q_cons_vf(i)%sf(m+j, k, l) = & + q_cons_vf(i)%sf(m + j, k, l) = & q_cons_vf(i)%sf(m, k, l) end if end do @@ -1005,7 +1004,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -1025,7 +1024,7 @@ module m_boundary_conditions end if - !< y-direction ========================================================= + !< y-direction ========================================================= elseif (bc_dir == 2) then if (bc_loc == -1) then !< bc_y%beg @@ -1047,7 +1046,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -1084,7 +1083,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -1092,9 +1091,9 @@ module m_boundary_conditions do j = 1, buff_size do l = -buff_size, m + buff_size pb(l, n + j, k, q, i) = & - pb(l, n , k, q, i) + pb(l, n, k, q, i) mv(l, n + j, k, q, i) = & - mv(l, n , k, q, i) + mv(l, n, k, q, i) end do end do end do @@ -1103,8 +1102,8 @@ module m_boundary_conditions end if end if - - !< z-direction ========================================================= + + !< z-direction ========================================================= elseif (bc_dir == 3) then if (bc_loc == -1) then !< bc_z%beg @@ -1116,7 +1115,7 @@ module m_boundary_conditions do k = -buff_size, m + buff_size if (i == momxe) then q_cons_vf(i)%sf(k, l, -j) = & - - q_cons_vf(i)%sf(k, l, j - 1) + -q_cons_vf(i)%sf(k, l, j - 1) else q_cons_vf(i)%sf(k, l, -j) = & q_cons_vf(i)%sf(k, l, 0) @@ -1126,7 +1125,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -1155,7 +1154,7 @@ module m_boundary_conditions q_cons_vf(i)%sf(k, l, p + j) = & -q_cons_vf(i)%sf(k, l, p - (j - 1)) else - q_cons_vf(i)%sf(k, l, p+j) = & + q_cons_vf(i)%sf(k, l, p + j) = & q_cons_vf(i)%sf(k, l, p) end if end do @@ -1163,23 +1162,23 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode do j = 1, buff_size do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size - pb(k, l, p+j, q, i) = & + pb(k, l, p + j, q, i) = & pb(k, l, p, q, i) - mv(k, l, p+j, q, i) = & + mv(k, l, p + j, q, i) = & mv(k, l, p, q, i) end do end do end do end do end do - end if + end if end if @@ -1191,7 +1190,7 @@ module m_boundary_conditions subroutine s_no_slip_wall(q_cons_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size) :: q_cons_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: pb, mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: pb, mv integer :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -1206,8 +1205,8 @@ module m_boundary_conditions do k = 0, n do j = 1, buff_size if (i >= momxb .and. i <= momxe) then - q_cons_vf(i)%sf(-j,k,l) = & - - q_cons_vf(i)%sf(j - 1, k, l) + q_cons_vf(i)%sf(-j, k, l) = & + -q_cons_vf(i)%sf(j - 1, k, l) else q_cons_vf(i)%sf(-j, k, l) = & q_cons_vf(i)%sf(0, k, l) @@ -1217,7 +1216,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(4) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -1225,9 +1224,9 @@ module m_boundary_conditions do k = 0, n do j = 1, buff_size pb(-j, k, l, q, i) = & - pb(0, k, l, q, i) + pb(0, k, l, q, i) mv(-j, k, l, q, i) = & - mv(0, k, l, q, i) + mv(0, k, l, q, i) end do end do end do @@ -1243,10 +1242,10 @@ module m_boundary_conditions do k = 0, n do j = 1, buff_size if (i >= momxb .and. i <= momxe) then - q_cons_vf(i)%sf(m+j,k,l) = & - - q_cons_vf(i)%sf(m - (j - 1), k, l) + q_cons_vf(i)%sf(m + j, k, l) = & + -q_cons_vf(i)%sf(m - (j - 1), k, l) else - q_cons_vf(i)%sf(m+j, k, l) = & + q_cons_vf(i)%sf(m + j, k, l) = & q_cons_vf(i)%sf(m, k, l) end if end do @@ -1254,7 +1253,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -1274,7 +1273,7 @@ module m_boundary_conditions end if - !< y-direction ========================================================= + !< y-direction ========================================================= elseif (bc_dir == 2) then if (bc_loc == -1) then !< bc_y%beg @@ -1286,7 +1285,7 @@ module m_boundary_conditions do l = -buff_size, m + buff_size if (i >= momxb .and. i <= momxe) then q_cons_vf(i)%sf(l, -j, k) = & - - q_cons_vf(i)%sf(l, (j - 1), k) + -q_cons_vf(i)%sf(l, (j - 1), k) else q_cons_vf(i)%sf(l, -j, k) = & q_cons_vf(i)%sf(l, 0, k) @@ -1296,7 +1295,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -1323,7 +1322,7 @@ module m_boundary_conditions do l = -buff_size, m + buff_size if (i == momxb + 1) then q_cons_vf(i)%sf(l, n + j, k) = & - - q_cons_vf(i)%sf(l, n - (j - 1), k) + -q_cons_vf(i)%sf(l, n - (j - 1), k) else q_cons_vf(i)%sf(l, n + j, k) = & q_cons_vf(i)%sf(l, n, k) @@ -1333,7 +1332,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -1341,9 +1340,9 @@ module m_boundary_conditions do j = 1, buff_size do l = -buff_size, m + buff_size pb(l, n + j, k, q, i) = & - pb(l, n , k, q, i) + pb(l, n, k, q, i) mv(l, n + j, k, q, i) = & - mv(l, n , k, q, i) + mv(l, n, k, q, i) end do end do end do @@ -1352,8 +1351,8 @@ module m_boundary_conditions end if end if - - !< z-direction ========================================================= + + !< z-direction ========================================================= elseif (bc_dir == 3) then if (bc_loc == -1) then !< bc_z%beg @@ -1365,7 +1364,7 @@ module m_boundary_conditions do k = -buff_size, m + buff_size if (i >= momxb .and. i <= momxe) then q_cons_vf(i)%sf(k, l, -j) = & - - q_cons_vf(i)%sf(k, l, j - 1) + -q_cons_vf(i)%sf(k, l, j - 1) else q_cons_vf(i)%sf(k, l, -j) = & q_cons_vf(i)%sf(k, l, 0) @@ -1375,7 +1374,7 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode @@ -1401,10 +1400,10 @@ module m_boundary_conditions do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size if (i >= momxb .and. i <= momxe) then - q_cons_vf(i)%sf(k, l, p+j) = & + q_cons_vf(i)%sf(k, l, p + j) = & -q_cons_vf(i)%sf(k, l, p - (j - 1)) else - q_cons_vf(i)%sf(k, l, p+j) = & + q_cons_vf(i)%sf(k, l, p + j) = & q_cons_vf(i)%sf(k, l, p) end if end do @@ -1412,23 +1411,23 @@ module m_boundary_conditions end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do q = 1, nnode do j = 1, buff_size do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size - pb(k, l, p+ j, q, i) = & + pb(k, l, p + j, q, i) = & pb(k, l, p, q, i) - mv(k, l, p+j, q, i) = & + mv(k, l, p + j, q, i) = & mv(k, l, p, q, i) end do end do end do end do end do - end if + end if end if @@ -1437,4 +1436,4 @@ module m_boundary_conditions end subroutine s_no_slip_wall -end module m_boundary_conditions \ No newline at end of file +end module m_boundary_conditions diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index 2f6a607ae..99cc2163e 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -29,10 +29,9 @@ module m_bubbles integer, allocatable, dimension(:) :: rs, vs, ms, ps !$acc declare create(rs, vs, ms, ps) - contains - subroutine s_initialize_bubbles_module() + subroutine s_initialize_bubbles_module() integer :: i, j, k, l, q @@ -57,7 +56,7 @@ contains !$acc update device(ps, ms) end if - end subroutine + end subroutine !> The purpose of this procedure is to compute the source terms !! that are needed for the bubble modeling @@ -70,16 +69,16 @@ contains !! @param bub_p_src Bubble pressure equation source !! @param bub_m_src Bubble mass equation source 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) + 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), 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 + 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 @@ -103,7 +102,7 @@ contains real(kind(0d0)), dimension(2) :: Re !< Reynolds number integer :: i, j, k, l, q, ii !< Loop variables - integer :: ndirs !< Number of coordinate directions + integer :: ndirs !< Number of coordinate directions !$acc parallel loop collapse(3) gang vector default(present) private(Rtmp, Vtmp) do l = 0, p @@ -111,7 +110,7 @@ contains do j = 0, m bub_adv_src(j, k, l) = 0d0 -!$acc loop seq + !$acc loop seq do q = 1, nb bub_r_src(j, k, l, q) = 0d0 bub_v_src(j, k, l, q) = 0d0 @@ -127,7 +126,7 @@ contains do k = 0, n do j = 0, m -!$acc loop seq + !$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) @@ -193,9 +192,9 @@ contains 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' - B_tait = B_tait*(n_tait-1)/n_tait ! make this the usual pi_inf + B_tait = B_tait*(n_tait - 1)/n_tait ! make this the usual pi_inf myRho = q_prim_vf(1)%sf(j, k, l) myP = q_prim_vf(E_idx)%sf(j, k, l) @@ -252,7 +251,7 @@ contains end do end do end do - end do + end do !$acc parallel loop collapse(3) gang vector default(present) do l = 0, p @@ -282,7 +281,7 @@ contains !! @param fV Current bubble velocity !! @param fpb Internal bubble pressure function f_cpbw(fR0, fR, fV, fpb) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(IN) :: fR0, fR, fV, fpb real(kind(0d0)) :: f_cpbw @@ -301,7 +300,7 @@ contains !! @param fntait Tait EOS parameter !! @param fBtait Tait EOS parameter function f_H(fCpbw, fCpinf, fntait, fBtait) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(IN) :: fCpbw, fCpinf, fntait, fBtait real(kind(0d0)) :: tmp1, tmp2, tmp3 @@ -321,7 +320,7 @@ contains !! @param fBtait Tait EOS parameter !! @param fH Bubble enthalpy function f_cgas(fCpinf, fntait, fBtait, fH) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(IN) :: fCpinf, fntait, fBtait, fH real(kind(0d0)) :: tmp @@ -344,7 +343,7 @@ contains !! @param advsrc Advection equation source term !! @param divu Divergence of velocity function f_cpinfdot(fRho, fP, falf, fntait, fBtait, advsrc, divu) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(IN) :: fRho, fP, falf, fntait, fBtait, advsrc, divu real(kind(0d0)) :: c2_liquid @@ -374,7 +373,7 @@ contains !! @param fV Current bubble velocity !! @param fpbdot Time derivative of the internal bubble pressure function f_Hdot(fCpbw, fCpinf, fCpinf_dot, fntait, fBtait, fR, fV, fR0, fpbdot) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(IN) :: fCpbw, fCpinf, fCpinf_dot, fntait, fBtait real(kind(0d0)), intent(IN) :: fR, fV, fR0, fpbdot @@ -410,7 +409,7 @@ contains !! @param fR0 Equilibrium bubble radius !! @param fCpbw Boundary wall pressure function f_rddot_RP(fCp, fRho, fR, fV, fR0, fCpbw) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(IN) :: fCp, fRho, fR, fV, fR0, fCpbw real(kind(0d0)) :: f_rddot_RP @@ -432,7 +431,7 @@ contains !! @param fntait Tait EOS parameter !! @param fBtait Tait EOS parameter function f_rddot(fCpbw, fR, fV, fH, fHdot, fcgas, fntait, fBtait) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(IN) :: fCpbw, fR, fV, fH, fHdot real(kind(0d0)), intent(IN) :: fcgas, fntait, fBtait @@ -455,7 +454,7 @@ contains !! @param fV Current bubble velocity !! @param fpb Internal bubble pressure function f_cpbw_KM(fR0, fR, fV, fpb) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(IN) :: fR0, fR, fV, fpb real(kind(0d0)) :: f_cpbw_KM @@ -482,7 +481,7 @@ contains !! @param fR0 Equilibrium bubble radius !! @param fC Current sound speed function f_rddot_KM(fpbdot, fCp, fCpbw, fRho, fR, fV, fR0, fC) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(IN) :: fpbdot, fCp, fCpbw real(kind(0d0)), intent(IN) :: fRho, fR, fV, fR0, fC @@ -517,7 +516,7 @@ contains !> @param pb Internal bubble pressure !> @param iR0 Current bubble size index subroutine s_bwproperty(pb, iR0) -!$acc routine seq + !$acc routine seq real(kind(0.d0)), intent(IN) :: pb integer, intent(IN) :: iR0 @@ -540,7 +539,7 @@ contains !! @param fmass_v Current mass of vapour !! @param iR0 Bubble size index function f_vflux(fR, fV, fmass_v, iR0) -!$acc routine seq + !$acc routine seq real(kind(0.d0)), intent(IN) :: fR real(kind(0.d0)), intent(IN) :: fV real(kind(0.d0)), intent(IN) :: fmass_v @@ -571,7 +570,7 @@ contains !! @param fmass_v Current mass of vapour !! @param iR0 Bubble size index function f_bpres_dot(fvflux, fR, fV, fpb, fmass_v, iR0) -!$acc routine seq + !$acc routine seq real(kind(0.d0)), intent(IN) :: fvflux real(kind(0.d0)), intent(IN) :: fR real(kind(0.d0)), intent(IN) :: fV diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index de2ba373b..822e66dfd 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -89,10 +89,10 @@ module m_cbc integer :: cbc_dir, cbc_loc -!$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,Re, & -!$acc ds,fd_coef_x,fd_coef_y,fd_coef_z, & -!$acc pi_coef_x,pi_coef_y,pi_coef_z, bcxb, bcxe, bcyb, bcye, bczb, bcze, is1, is2, is3, dj, cbc_dir, cbc_loc) + !$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,Re, & + !$acc ds,fd_coef_x,fd_coef_y,fd_coef_z, & + !$acc pi_coef_x,pi_coef_y,pi_coef_z, bcxb, bcxe, bcyb, bcye, bczb, bcze, is1, is2, is3, dj, cbc_dir, cbc_loc) contains @@ -241,11 +241,9 @@ contains end if - ! Allocating the cell-width distribution in the s-direction allocate (ds(0:buff_size)) - ! Allocating/Computing CBC Coefficients in x-direction ============= if (all((/bc_x%beg, bc_x%end/) <= -5) .and. all((/bc_x%beg, bc_x%end/) >= -13)) then @@ -385,7 +383,6 @@ contains end subroutine s_initialize_cbc_module ! ------------------------------- - !> Compute CBC coefficients !! @param cbc_dir_in CBC coordinate direction !! @param cbc_loc_in CBC coordinate location @@ -415,76 +412,76 @@ contains ! Computing CBC1 Coefficients ====================================== #:for CBC_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - if (cbc_dir_in == ${CBC_DIR}$) then - if (weno_order == 1) then - - fd_coef_${XYZ}$(:, cbc_loc_in) = 0d0 - fd_coef_${XYZ}$(0, cbc_loc_in) = -2d0/(ds(0) + ds(1)) - fd_coef_${XYZ}$(1, cbc_loc_in) = -fd_coef_${XYZ}$(0, cbc_loc_in) - - ! ================================================================== - - ! Computing CBC2 Coefficients ====================================== - elseif (weno_order == 3) then - - fd_coef_${XYZ}$(:, cbc_loc_in) = 0d0 - fd_coef_${XYZ}$(0, cbc_loc_in) = -6d0/(3d0*ds(0) + 2d0*ds(1) - ds(2)) - fd_coef_${XYZ}$(1, cbc_loc_in) = -4d0*fd_coef_${XYZ}$(0, cbc_loc_in)/3d0 - fd_coef_${XYZ}$(2, cbc_loc_in) = fd_coef_${XYZ}$(0, cbc_loc_in)/3d0 - - pi_coef_${XYZ}$(0, 0, cbc_loc_in) = (s_cb(0) - s_cb(1))/(s_cb(0) - s_cb(2)) - - ! ================================================================== - - ! Computing CBC4 Coefficients ====================================== - else - - fd_coef_${XYZ}$(:, cbc_loc_in) = 0d0 - fd_coef_${XYZ}$(0, cbc_loc_in) = -50d0/(25d0*ds(0) + 2d0*ds(1) & - - 1d1*ds(2) + 1d1*ds(3) & - - 3d0*ds(4)) - fd_coef_${XYZ}$(1, cbc_loc_in) = -48d0*fd_coef_${XYZ}$(0, cbc_loc_in)/25d0 - fd_coef_${XYZ}$(2, cbc_loc_in) = 36d0*fd_coef_${XYZ}$(0, cbc_loc_in)/25d0 - fd_coef_${XYZ}$(3, cbc_loc_in) = -16d0*fd_coef_${XYZ}$(0, cbc_loc_in)/25d0 - fd_coef_${XYZ}$(4, cbc_loc_in) = 3d0*fd_coef_${XYZ}$(0, cbc_loc_in)/25d0 - - pi_coef_${XYZ}$(0, 0, cbc_loc_in) = & - ((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_${XYZ}$(0, 1, cbc_loc_in) = & - ((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_${XYZ}$(0, 2, cbc_loc_in) = & - (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_${XYZ}$(1, 0, cbc_loc_in) = & - ((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_${XYZ}$(1, 1, cbc_loc_in) = & - ((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_${XYZ}$(1, 2, cbc_loc_in) = & - ((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))) + if (cbc_dir_in == ${CBC_DIR}$) then + if (weno_order == 1) then + + fd_coef_${XYZ}$ (:, cbc_loc_in) = 0d0 + fd_coef_${XYZ}$ (0, cbc_loc_in) = -2d0/(ds(0) + ds(1)) + fd_coef_${XYZ}$ (1, cbc_loc_in) = -fd_coef_${XYZ}$ (0, cbc_loc_in) + + ! ================================================================== + + ! Computing CBC2 Coefficients ====================================== + elseif (weno_order == 3) then + + fd_coef_${XYZ}$ (:, cbc_loc_in) = 0d0 + fd_coef_${XYZ}$ (0, cbc_loc_in) = -6d0/(3d0*ds(0) + 2d0*ds(1) - ds(2)) + fd_coef_${XYZ}$ (1, cbc_loc_in) = -4d0*fd_coef_${XYZ}$ (0, cbc_loc_in)/3d0 + fd_coef_${XYZ}$ (2, cbc_loc_in) = fd_coef_${XYZ}$ (0, cbc_loc_in)/3d0 + + pi_coef_${XYZ}$ (0, 0, cbc_loc_in) = (s_cb(0) - s_cb(1))/(s_cb(0) - s_cb(2)) + + ! ================================================================== + + ! Computing CBC4 Coefficients ====================================== + else + + fd_coef_${XYZ}$ (:, cbc_loc_in) = 0d0 + fd_coef_${XYZ}$ (0, cbc_loc_in) = -50d0/(25d0*ds(0) + 2d0*ds(1) & + - 1d1*ds(2) + 1d1*ds(3) & + - 3d0*ds(4)) + fd_coef_${XYZ}$ (1, cbc_loc_in) = -48d0*fd_coef_${XYZ}$ (0, cbc_loc_in)/25d0 + fd_coef_${XYZ}$ (2, cbc_loc_in) = 36d0*fd_coef_${XYZ}$ (0, cbc_loc_in)/25d0 + fd_coef_${XYZ}$ (3, cbc_loc_in) = -16d0*fd_coef_${XYZ}$ (0, cbc_loc_in)/25d0 + fd_coef_${XYZ}$ (4, cbc_loc_in) = 3d0*fd_coef_${XYZ}$ (0, cbc_loc_in)/25d0 + + pi_coef_${XYZ}$ (0, 0, cbc_loc_in) = & + ((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_${XYZ}$ (0, 1, cbc_loc_in) = & + ((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_${XYZ}$ (0, 2, cbc_loc_in) = & + (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_${XYZ}$ (1, 0, cbc_loc_in) = & + ((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_${XYZ}$ (1, 1, cbc_loc_in) = & + ((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_${XYZ}$ (1, 2, cbc_loc_in) = & + ((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 - end if #:endfor - + ! END: Computing CBC4 Coefficients ================================= ! Nullifying CBC coefficients @@ -629,332 +626,331 @@ contains !$acc update device(cbc_dir, cbc_loc) - call s_initialize_cbc(q_prim_vf, flux_vf, flux_src_vf, & ix, iy, iz) call s_associate_cbc_coefficients_pointers(cbc_dir, cbc_loc) #:for CBC_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - if (cbc_dir == ${CBC_DIR}$) then + 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 + ! 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_rs${XYZ}$_vf, & - F_rs${XYZ}$_vf, & - F_src_rs${XYZ}$_vf, & - is1, is2, is3, starty, startz) + 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_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 - - !$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_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 - ! ================================================================== - - ! 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_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) - do i = 1, advxe - do j = 0, 1 + !$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_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)) + 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 - end do - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb, advxe - do j = 0, 1 + !$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_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) + 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 - 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_rs${XYZ}$_vf(0, k, r, i) + ! ================================================================== + + ! 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_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) + do i = 1, advxe + do j = 0, 1 + do r = is3%beg, is3%end + do k = is2%beg, is2%end + 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 end do - !$acc loop seq - do i = 1, num_dims - vel(i) = q_prim_rs${XYZ}$_vf(0, k, r, contxe + i) + !$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_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 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 + end if + ! ================================================================== - pres = q_prim_rs${XYZ}$_vf(0, k, r, E_idx) + ! 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 - !$acc loop seq - do i = 1, advxe - E_idx - adv(i) = q_prim_rs${XYZ}$_vf(0, k, r, E_idx + i) - end do + ! Transferring the Primitive Variables ======================= + !$acc loop seq + do i = 1, contxe + alpha_rho(i) = q_prim_rs${XYZ}$_vf(0, k, r, i) + end do - if (bubbles) then - call s_convert_species_to_mixture_variables_bubbles_acc(rho, gamma, pi_inf, qv, adv, alpha_rho, Re_cbc, 0, k, r) + !$acc loop seq + do i = 1, num_dims + vel(i) = q_prim_rs${XYZ}$_vf(0, k, r, contxe + i) + end do - else - call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv, adv, alpha_rho, Re_cbc, 0, k, r) - end if + vel_K_sum = 0d0 + !$acc loop seq + do i = 1, num_dims + vel_K_sum = vel_K_sum + vel(i)**2d0 + end do - !$acc loop seq - do i = 1, contxe - mf(i) = alpha_rho(i)/rho - end do + pres = q_prim_rs${XYZ}$_vf(0, k, r, E_idx) - E = gamma*pres + pi_inf + 5d-1*rho*vel_K_sum + !$acc loop seq + do i = 1, advxe - E_idx + adv(i) = q_prim_rs${XYZ}$_vf(0, k, r, E_idx + i) + end do - H = (E + pres)/rho + if (bubbles) then + call s_convert_species_to_mixture_variables_bubbles_acc(rho, gamma, pi_inf, qv, adv, alpha_rho, Re_cbc, 0, k, r) - ! Compute mixture sound speed - call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, H, adv, vel_K_sum, c) - ! ============================================================ + else + call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv, adv, alpha_rho, Re_cbc, 0, k, r) + end if - ! First-Order Spatial Derivatives of Primitive Variables ===== + !$acc loop seq + do i = 1, contxe + mf(i) = alpha_rho(i)/rho + end do - !$acc loop seq - do i = 1, contxe - dalpha_rho_ds(i) = 0d0 - end do + E = gamma*pres + pi_inf + 5d-1*rho*vel_K_sum - !$acc loop seq - do i = 1, num_dims - dvel_ds(i) = 0d0 - end do + H = (E + pres)/rho - dpres_ds = 0d0 - !$acc loop seq - do i = 1, advxe - E_idx - dadv_ds(i) = 0d0 - end do + ! Compute mixture sound speed + call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, H, adv, vel_K_sum, c) + ! ============================================================ - !$acc loop seq - do j = 0, buff_size + ! First-Order Spatial Derivatives of Primitive Variables ===== !$acc loop seq do i = 1, contxe - dalpha_rho_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, i)* & - fd_coef_${XYZ}$(j, cbc_loc) + & - dalpha_rho_ds(i) + dalpha_rho_ds(i) = 0d0 end do + !$acc loop seq do i = 1, num_dims - dvel_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, contxe + i)* & - fd_coef_${XYZ}$(j, cbc_loc) + & - dvel_ds(i) + dvel_ds(i) = 0d0 end do - dpres_ds = q_prim_rs${XYZ}$_vf(j, k, r, E_idx)* & - fd_coef_${XYZ}$(j, cbc_loc) + & - dpres_ds + dpres_ds = 0d0 !$acc loop seq do i = 1, advxe - E_idx - dadv_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, E_idx + i)* & - fd_coef_${XYZ}$(j, cbc_loc) + & - dadv_ds(i) + dadv_ds(i) = 0d0 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 - - if ((cbc_loc == -1 .and. bc${XYZ}$b == -5) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -5)) then - call s_compute_slip_wall_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bc${XYZ}$b == -6) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -6)) then - call s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bc${XYZ}$b == -7) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -7)) then - call s_compute_nonreflecting_subsonic_inflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bc${XYZ}$b == -8) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -8)) then - call s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bc${XYZ}$b == -9) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -9)) then - call s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bc${XYZ}$b == -10) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -10)) then - call s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else if ((cbc_loc == -1 .and. bc${XYZ}$b == -11) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -11)) then - call s_compute_supersonic_inflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - else - call s_compute_supersonic_outflow_L(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 - 1) - end do + !$acc loop seq + do j = 0, buff_size - 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 + !$acc loop seq + do i = 1, contxe + 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_rs${XYZ}$_vf(j, k, r, contxe + i)* & + fd_coef_${XYZ}$ (j, cbc_loc) + & + dvel_ds(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) + 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_rs${XYZ}$_vf(j, k, r, E_idx + i)* & + fd_coef_${XYZ}$ (j, cbc_loc) + & + dadv_ds(i) + end do end do - end if + ! ============================================================ + + ! 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 + + if ((cbc_loc == -1 .and. bc${XYZ}$b == -5) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -5)) then + call s_compute_slip_wall_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- + else if ((cbc_loc == -1 .and. bc${XYZ}$b == -6) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -6)) then + call s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- + else if ((cbc_loc == -1 .and. bc${XYZ}$b == -7) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -7)) then + call s_compute_nonreflecting_subsonic_inflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- + else if ((cbc_loc == -1 .and. bc${XYZ}$b == -8) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -8)) then + call s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- + else if ((cbc_loc == -1 .and. bc${XYZ}$b == -9) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -9)) then + call s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- + else if ((cbc_loc == -1 .and. bc${XYZ}$b == -10) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -10)) then + call s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- + else if ((cbc_loc == -1 .and. bc${XYZ}$b == -11) .or. (cbc_loc == 1 .and. bc${XYZ}$e == -11)) then + call s_compute_supersonic_inflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- + else + call s_compute_supersonic_outflow_L(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 - drho_dt = 0d0; dgamma_dt = 0d0; dpi_inf_dt = 0d0; dqv_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) - dqv_dt = dqv_dt + dalpha_rho_dt(i)*qvs(i) + do i = 1, contxe + dalpha_rho_dt(i) = & + -(L(i + 1) - mf(i)*dpres_dt)/(c*c) end do - end if - ! ============================================================ - - ! flux_rs_vf and flux_src_rs_vf at j = -1/2 ================== - !$acc loop seq - do i = 1, contxe - 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_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_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 & - + dqv_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_rs${XYZ}$_vf(-1, k, r, i) = 0d0 + 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 - 1) end do + vel_dv_dt_sum = 0d0 !$acc loop seq - do i = advxb, advxe - 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_rs${XYZ}$_vf(0, k, r, i) & - + vel(dir_idx(1)) & - *flux_src_rs${XYZ}$_vf(0, k, r, i) & - + ds(0)*dadv_dt(i - E_idx)) + do i = 1, num_dims + vel_dv_dt_sum = vel_dv_dt_sum + vel(i)*dvel_dt(i) end do - else + ! 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; dqv_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) + dqv_dt = dqv_dt + dalpha_rho_dt(i)*qvs(i) + end do + end if + ! ============================================================ + ! flux_rs_vf and flux_src_rs_vf at j = -1/2 ================== !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(-1, k, r, i) = flux_rs${XYZ}$_vf(0, k, r, i) + & - ds(0)*dadv_dt(i - E_idx) + do i = 1, contxe + 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 = advxb, advxe - flux_src_rs${XYZ}$_vf(-1, k, r, i) = flux_src_rs${XYZ}$_vf(0, k, r, i) + do i = momxb, momxe + 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 - end if - ! END: flux_rs_vf and flux_src_rs_vf at j = -1/2 ============= + 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 & + + dqv_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_rs${XYZ}$_vf(-1, k, r, i) = 0d0 + end do + + !$acc loop seq + do i = advxb, advxe + 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_rs${XYZ}$_vf(0, k, r, i) & + + vel(dir_idx(1)) & + *flux_src_rs${XYZ}$_vf(0, k, r, i) & + + ds(0)*dadv_dt(i - E_idx)) + end do + else + + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(-1, k, r, i) = flux_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_rs${XYZ}$_vf(-1, k, r, i) = flux_src_rs${XYZ}$_vf(0, k, r, i) + end do + + end if + ! END: flux_rs_vf and flux_src_rs_vf at j = -1/2 ============= + + end do end do - end do - end if + end if #:endfor ! END: FD2 or FD4 of RHS at j = 0 ================================== @@ -1017,7 +1013,7 @@ contains ! Reshaping Inputted Data in x-direction =========================== if (cbc_dir == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, sys_size do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1029,7 +1025,7 @@ contains end do end do -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = 0, buff_size @@ -1040,7 +1036,7 @@ contains end do end do -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1053,7 +1049,7 @@ contains end do end do -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size @@ -1063,8 +1059,8 @@ contains end do end do - if(riemann_solver == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + if (riemann_solver == 1) then + !$acc parallel loop collapse(4) gang vector default(present) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1076,7 +1072,7 @@ contains end do end do else -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size @@ -1088,14 +1084,12 @@ contains end do end if - - ! END: Reshaping Inputted Data in x-direction ====================== ! Reshaping Inputted Data in y-direction =========================== elseif (cbc_dir == 2) then -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, sys_size do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1107,7 +1101,7 @@ contains end do end do -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = 0, buff_size @@ -1118,7 +1112,7 @@ contains end do end do -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1131,7 +1125,7 @@ contains end do end do -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size @@ -1141,8 +1135,8 @@ contains end do end do - if(riemann_solver == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + if (riemann_solver == 1) then + !$acc parallel loop collapse(4) gang vector default(present) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1154,7 +1148,7 @@ contains end do end do else -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size @@ -1164,15 +1158,14 @@ contains end do end do end do - end if - + end if ! END: Reshaping Inputted Data in y-direction ====================== ! Reshaping Inputted Data in z-direction =========================== else -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, sys_size do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1184,7 +1177,7 @@ contains end do end do -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = 0, buff_size @@ -1195,7 +1188,7 @@ contains end do end do -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1208,7 +1201,7 @@ contains end do end do -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size @@ -1218,8 +1211,8 @@ contains end do end do - if(riemann_solver == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + if (riemann_solver == 1) then + !$acc parallel loop collapse(4) gang vector default(present) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1231,7 +1224,7 @@ contains end do end do else -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size @@ -1240,10 +1233,9 @@ contains sign(1d0, -real(cbc_loc, kind(0d0))) end do end do - end do + end do end if - end if ! END: Reshaping Inputted Data in z-direction ====================== @@ -1281,7 +1273,7 @@ contains ! Reshaping Outputted Data in x-direction ========================== if (cbc_dir == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1293,7 +1285,7 @@ contains end do end do end do -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size @@ -1303,8 +1295,8 @@ contains end do end do - if(riemann_solver == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + if (riemann_solver == 1) then + !$acc parallel loop collapse(4) gang vector default(present) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1316,13 +1308,13 @@ contains end do end do else -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r) = & flux_src_rsx_vf(j, k, r, advxb)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1d0, -real(cbc_loc, kind(0d0))) end do end do end do @@ -1332,7 +1324,7 @@ contains ! Reshaping Outputted Data in y-direction ========================== elseif (cbc_dir == 2) then -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1345,7 +1337,7 @@ contains end do end do -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size @@ -1355,8 +1347,8 @@ contains end do end do - if(riemann_solver == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + if (riemann_solver == 1) then + !$acc parallel loop collapse(4) gang vector default(present) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1368,16 +1360,16 @@ contains end do end do else -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r) = & flux_src_rsy_vf(j, k, r, advxb)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1d0, -real(cbc_loc, kind(0d0))) end do end do - end do + end do end if ! END: Reshaping Outputted Data in y-direction ===================== @@ -1385,7 +1377,7 @@ contains ! Reshaping Outputted Data in z-direction ========================== else -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1398,7 +1390,7 @@ contains end do end do -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size @@ -1408,8 +1400,8 @@ contains end do end do - if(riemann_solver == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + if (riemann_solver == 1) then + !$acc parallel loop collapse(4) gang vector default(present) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end @@ -1421,19 +1413,18 @@ contains end do end do else -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j) = & flux_src_rsz_vf(j, k, r, advxb)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1d0, -real(cbc_loc, kind(0d0))) end do end do end do end if - end if ! END: Reshaping Outputted Data in z-direction ===================== @@ -1453,9 +1444,9 @@ contains toggle = .false. #:for BC in {-5, -6, -7, -8, -9, -10, -11, -12, -13} - if (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == ${BC}$)) then - toggle = .true. - end if + if (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == ${BC}$)) then + toggle = .true. + end if #:endfor end subroutine @@ -1501,7 +1492,7 @@ contains ! ================================================================== ! Deallocating CBC Coefficients in y-direction ===================== - if (n > 0 .and. any((/bc_y%beg, bc_y%end/) <= -5) .and. & + if (n > 0 .and. any((/bc_y%beg, bc_y%end/) <= -5) .and. & any((/bc_y%beg, bc_y%end/) >= -13 .and. bc_y%beg /= -14)) then deallocate (fd_coef_y); if (weno_order > 1) deallocate (pi_coef_y) end if diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index de98dd60c..ee65090a0 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -4,7 +4,7 @@ #:include 'case.fpp' -!> @brief The purpose of the module is to check for compatible input files +!> @brief The purpose of the module is to check for compatible input files module m_checker use m_global_parameters !< Definitions of the global parameters @@ -38,7 +38,7 @@ contains #ifndef MFC_cuTENSOR if (cu_tensor) then call s_mpi_abort('Unsupported value of cu_tensor. MFC was not built '// & - 'with the NVIDIA cuTENSOR library. Exiting ...') + 'with the NVIDIA cuTENSOR library. Exiting ...') end if #endif @@ -53,19 +53,19 @@ contains call s_mpi_abort('Unsupported value of p. Exiting ...') elseif (n == 0 .and. p > 0) then call s_mpi_abort('Unsupported combination of values of '// & - 'n and p. Exiting ...') + 'n and p. Exiting ...') elseif (dt <= 0) then call s_mpi_abort('Unsupported value of dt. Exiting ...') elseif (t_step_start < 0) then call s_mpi_abort('Unsupported value of t_step_start. Exiting ...') elseif (t_step_stop <= t_step_start) then call s_mpi_abort('Unsupported combination of values of '// & - 't_step_start and t_step_stop. '// & - 'Exiting ...') - elseif (t_step_save > t_step_stop - t_step_start) then + 't_step_start and t_step_stop. '// & + 'Exiting ...') + elseif (t_step_save > t_step_stop - t_step_start) then call s_mpi_abort('Unsupported combination of values of '// & - 't_step_start, t_step_stop and '// & - 't_step_save. Exiting ...') + 't_step_start, t_step_stop and '// & + 't_step_save. Exiting ...') end if ! ================================================================== @@ -81,19 +81,19 @@ contains call s_mpi_abort('The Ensemble-Averaged Bubble Model requires nb >= 1') elseif (bubble_model == 3 .and. (polytropic .neqv. .true.) .and. (.not. qbmm)) then call s_mpi_abort('RP bubbles require polytropic compression') - elseif (cyl_coord) then + elseif (cyl_coord) then call s_mpi_abort('Bubble models untested in cylindrical coordinates') elseif (model_eqns == 3) then call s_mpi_abort('Bubble models untested with 6-equation model') elseif (model_eqns == 1) then call s_mpi_abort('Bubble models untested with pi-gamma model') - !TODO: Comment this out when testing riemann with hll + !TODO: Comment this out when testing riemann with hll elseif (riemann_solver /= 2) then call s_mpi_abort('Bubble modeling requires riemann_solver = 2') - elseif (avg_state == 1) then + elseif (avg_state == 1) then call s_mpi_abort('Unsupported combination of values of '// & - 'bubbles and Roe average (please use avg_state = 2). '// & - 'Exiting ...') + 'bubbles and Roe average (please use avg_state = 2). '// & + 'Exiting ...') end if end if @@ -105,102 +105,102 @@ contains call s_mpi_abort('Polydisperse bubble modeling requires the bubble switch to be activated') elseif (polydisperse .and. (poly_sigma == dflt_real)) then call s_mpi_abort('Polydisperse bubble modeling requires poly_sigma > 0') - elseif (qbmm .and. (bubbles .neqv. .true.)) then + elseif (qbmm .and. (bubbles .neqv. .true.)) then call s_mpi_abort('QBMM requires bubbles') elseif (qbmm .and. (nnode /= 4)) then call s_mpi_abort('nnode not supported') end if - if (model_eqns ==3 ) then + if (model_eqns == 3) then if (riemann_solver /= 2) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns (6-eq) and riemann_solver (please use riemann_solver = 2). '// & - 'Exiting ...') + 'model_eqns (6-eq) and riemann_solver (please use riemann_solver = 2). '// & + 'Exiting ...') elseif (alt_soundspeed) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns (6-eq) and alt_soundspeed. '// & - 'Exiting ...') + 'model_eqns (6-eq) and alt_soundspeed. '// & + 'Exiting ...') elseif (avg_state == 1) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns (6-eq) and Roe average (please use avg_state = 2). '// & - 'Exiting ...') + 'model_eqns (6-eq) and Roe average (please use avg_state = 2). '// & + 'Exiting ...') elseif (wave_speeds == 2) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns (6-eq) and wave_speeds (please use wave_speeds = 1). '// & - 'Exiting ...') + 'model_eqns (6-eq) and wave_speeds (please use wave_speeds = 1). '// & + 'Exiting ...') elseif (cyl_coord .and. p /= 0) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns (6-eq) and cylindrical coordinates. '// & - 'Exiting ...') + 'model_eqns (6-eq) and cylindrical coordinates. '// & + 'Exiting ...') end if end if ! phase change checkers. - if ( relax ) then - if ( model_eqns /= 3 ) then - call s_mpi_abort( 'phase change requires model_eqns = 3. ' // & - 'Exiting ...') - elseif ( ( relax_model .lt. 0 ) .or. ( relax_model .gt. 6 ) ) then - call s_mpi_abort( 'relax_model should be in between 0 and 6. ' // & - 'Exiting ...' ) - elseif ( ( palpha_eps .le. 0d0 ) .or. ( palpha_eps .ge. 1d0 ) .or. & - ( ptgalpha_eps .le. 0d0 ) .or. ( ptgalpha_eps .ge. 1d0 ) ) then - call s_mpi_abort( 'both palpha_eps and ptgalpha_eps must & - be in (0,1). ' // 'Exiting ...') - end if - elseif ( ( relax_model /= dflt_int ) .or. ( palpha_eps /= dflt_real ) & - .or. ( ptgalpha_eps /= dflt_real ) ) then - call s_mpi_abort( 'relax is not set as true, but other phase change parameters have & - been modified. Either activate phase change or set the values to default. ' // 'Exiting ...') + if (relax) then + if (model_eqns /= 3) then + call s_mpi_abort('phase change requires model_eqns = 3. '// & + 'Exiting ...') + elseif ((relax_model < 0) .or. (relax_model > 6)) then + call s_mpi_abort('relax_model should be in between 0 and 6. '// & + 'Exiting ...') + elseif ((palpha_eps <= 0d0) .or. (palpha_eps >= 1d0) .or. & + (ptgalpha_eps <= 0d0) .or. (ptgalpha_eps >= 1d0)) then + call s_mpi_abort('both palpha_eps and ptgalpha_eps must & + & be in (0,1). '//'Exiting ...') + end if + elseif ((relax_model /= dflt_int) .or. (palpha_eps /= dflt_real) & + .or. (ptgalpha_eps /= dflt_real)) then + call s_mpi_abort('relax is not set as true, but other phase change parameters have & +& been modified. Either activate phase change or set the values to default. '//'Exiting ...') end if if (num_fluids /= dflt_int & - .and. & - (num_fluids < 1 .or. num_fluids > num_fluids)) then + .and. & + (num_fluids < 1 .or. num_fluids > num_fluids)) then call s_mpi_abort('Unsupported value of num_fluids. Exiting ...') elseif ((model_eqns == 1 .and. num_fluids /= dflt_int) & .or. & (model_eqns == 2 .and. num_fluids == dflt_int)) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns and num_fluids. '// & - 'Exiting ...') + 'model_eqns and num_fluids. '// & + 'Exiting ...') elseif (model_eqns == 1 .and. adv_alphan) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns and adv_alphan. '// & - 'Exiting ...') + 'model_eqns and adv_alphan. '// & + 'Exiting ...') elseif (model_eqns == 1 .and. mpp_lim) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns and mpp_lim. Exiting ...') + 'model_eqns and mpp_lim. Exiting ...') elseif (num_fluids == 1 .and. mpp_lim) then call s_mpi_abort('Unsupported combination of values of '// & - 'num_fluids and mpp_lim. Exiting ...') + 'num_fluids and mpp_lim. Exiting ...') elseif (time_stepper < 1 .or. time_stepper > 5) then - if (time_stepper /= 23) then + if (time_stepper /= 23) then call s_mpi_abort('Unsupported value of time_stepper. Exiting ...') end if elseif (all(weno_order /= (/1, 3, 5/))) then call s_mpi_abort('Unsupported value of weno_order. Exiting ...') - elseif (m + 1 < num_stcls_min*weno_order) then + elseif (m + 1 < num_stcls_min*weno_order) then call s_mpi_abort('Unsupported combination of values of '// & - 'm and weno_order. Exiting ...') + 'm and weno_order. Exiting ...') elseif (n + 1 < min(1, n)*num_stcls_min*weno_order) then call s_mpi_abort('Unsupported combination of values of '// & - 'n and weno_order. Exiting ...') + 'n and weno_order. Exiting ...') elseif (p + 1 < min(1, p)*num_stcls_min*weno_order) then call s_mpi_abort('Unsupported combination of values of '// & - 'p and weno_order. Exiting ...') + 'p and weno_order. Exiting ...') elseif (weno_eps <= 0d0 .or. weno_eps > 1d-6) then call s_mpi_abort('Unsupported value of weno_eps. Exiting ...') elseif (weno_order == 1 .and. mapped_weno) then call s_mpi_abort('Unsupported combination of values of '// & - 'weno_order and mapped_weno. '// & - 'Exiting ...') + 'weno_order and mapped_weno. '// & + 'Exiting ...') elseif (weno_order /= 5 .and. mp_weno) then call s_mpi_abort('Unsupported combination of values of '// & - 'weno_order and mp_weno. Exiting ...') + 'weno_order and mp_weno. Exiting ...') elseif (model_eqns == 1 .and. weno_avg) then call s_mpi_abort('Unsupported combination of values of '// & - 'model_eqns and weno_avg. Exiting ...') + 'model_eqns and weno_avg. Exiting ...') elseif (riemann_solver < 1 .or. riemann_solver > 3) then call s_mpi_abort('Unsupported value of riemann_solver. Exiting ...') elseif (all(wave_speeds /= (/dflt_int, 1, 2/))) then @@ -209,14 +209,14 @@ contains .or. & (riemann_solver == 3 .and. wave_speeds /= dflt_int)) then call s_mpi_abort('Unsupported combination of values of '// & - 'riemann_solver and wave_speeds. '// & - 'Exiting ...') + 'riemann_solver and wave_speeds. '// & + 'Exiting ...') elseif (all(avg_state /= (/dflt_int, 1, 2/))) then call s_mpi_abort('Unsupported value of avg_state. Exiting ...') elseif (riemann_solver /= 3 .and. avg_state == dflt_int) then call s_mpi_abort('Unsupported combination of values of '// & - 'riemann_solver and avg_state. '// & - 'Exiting ...') + 'riemann_solver and avg_state. '// & + 'Exiting ...') elseif (bc_x%beg < -16 .or. bc_x%beg > -1 .or. bc_x%beg == -14) then call s_mpi_abort('Unsupported value of bc_x%beg. Exiting ...') elseif (bc_x%end < -16 .or. bc_x%end > -1 .or. bc_x%beg == -14) then @@ -225,7 +225,7 @@ contains .or. & (bc_x%end == -1 .and. bc_x%beg /= -1)) then call s_mpi_abort('Unsupported combination of values of '// & - 'bc_x%beg and bc_x%end. Exiting ...') + 'bc_x%beg and bc_x%end. Exiting ...') elseif (bc_y%beg /= dflt_int & .and. & (((cyl_coord .neqv. .true.) .and. (bc_y%beg < -16 .or. bc_y%beg > -1 .or. bc_y%beg == -14)) & @@ -236,23 +236,23 @@ contains call s_mpi_abort('Unsupported value of bc_y%beg. Exiting ...') elseif (bc_y%end /= dflt_int & .and. & - (bc_y%end < -16 .or. bc_y%end > -1 .or. bc_y%end == -14)) then + (bc_y%end < -16 .or. bc_y%end > -1 .or. bc_y%end == -14)) then call s_mpi_abort('Unsupported value of bc_y%end. Exiting ...') elseif ((n == 0 .and. bc_y%beg /= dflt_int) & .or. & (n > 0 .and. bc_y%beg == dflt_int)) then call s_mpi_abort('Unsupported combination of values of '// & - 'n and bc_y%beg. Exiting ...') + 'n and bc_y%beg. Exiting ...') elseif ((n == 0 .and. bc_y%end /= dflt_int) & .or. & - (n > 0 .and. bc_y%end == dflt_int)) then + (n > 0 .and. bc_y%end == dflt_int)) then call s_mpi_abort('Unsupported combination of values of '// & - 'n and bc_y%end. Exiting ...') + 'n and bc_y%end. Exiting ...') elseif ((bc_y%beg == -1 .and. bc_y%end /= -1) & .or. & (bc_y%end == -1 .and. bc_y%beg /= -1)) then call s_mpi_abort('Unsupported combination of values of '// & - 'bc_y%beg and bc_y%end. Exiting ...') + 'bc_y%beg and bc_y%end. Exiting ...') elseif (bc_z%beg /= dflt_int & .and. & (bc_z%beg < -16 .or. bc_z%beg > -1 .or. bc_z%beg == -14)) then @@ -267,32 +267,32 @@ contains .or. & (p > 0 .and. bc_z%beg == dflt_int)) then call s_mpi_abort('Unsupported combination of values of '// & - 'p and bc_z%beg. Exiting ...') + 'p and bc_z%beg. Exiting ...') elseif ((p == 0 .and. bc_z%end /= dflt_int) & .or. & (p > 0 .and. bc_z%end == dflt_int)) then call s_mpi_abort('Unsupported combination of values of '// & - 'p and bc_z%end. Exiting ...') + 'p and bc_z%end. Exiting ...') elseif ((bc_z%beg == -1 .and. bc_z%end /= -1) & .or. & (bc_z%end == -1 .and. bc_z%beg /= -1)) then call s_mpi_abort('Unsupported combination of values of '// & - 'bc_z%beg and bc_z%end. Exiting ...') + 'bc_z%beg and bc_z%end. Exiting ...') elseif (model_eqns == 1 .and. alt_soundspeed) then call s_mpi_abort('Unsupported combination of model_eqns '// & - 'and alt_soundspeed. Exiting ...') + 'and alt_soundspeed. Exiting ...') elseif (model_eqns == 4 .and. alt_soundspeed) then call s_mpi_abort('Unsupported combination of model_eqns '// & - 'and alt_soundspeed. Exiting ...') + 'and alt_soundspeed. Exiting ...') elseif ((num_fluids /= 2 .and. num_fluids /= 3) .and. alt_soundspeed) then call s_mpi_abort('Unsupported combination of num_fluids '// & - 'and alt_soundspeed. Exiting ...') + 'and alt_soundspeed. Exiting ...') elseif (riemann_solver /= 2 .and. alt_soundspeed) then - call s_mpi_abort( 'Unsupported combination of riemann_solver '// & - 'and alt_soundspeed. Exiting ...') + call s_mpi_abort('Unsupported combination of riemann_solver '// & + 'and alt_soundspeed. Exiting ...') elseif (hypoelasticity .and. (riemann_solver /= 1)) then - call s_mpi_abort( 'hypoelasticity requires riemann_solver = 1'// & - 'Exiting ...') + call s_mpi_abort('hypoelasticity requires riemann_solver = 1'// & + 'Exiting ...') end if ! END: Simulation Algorithm Parameters ============================= @@ -301,107 +301,107 @@ contains .and. & fd_order /= 1 .and. fd_order /= 2 .and. fd_order /= 4) then call s_mpi_abort('Unsupported choice for the value of '// & - 'fd_order. Exiting ...') + 'fd_order. Exiting ...') elseif (probe_wrt .and. fd_order == dflt_int) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for probe_wrt, and fd_order. '// & - 'Exiting ...') + 'values for probe_wrt, and fd_order. '// & + 'Exiting ...') elseif (integral_wrt .and. (bubbles .neqv. .true.)) then call s_mpi_abort('Unsupported choice of the combination of '// & - 'values for integral_wrt, and bubbles. '// & - 'Exiting ...') + 'values for integral_wrt, and bubbles. '// & + 'Exiting ...') end if ! END: Finite Difference Parameters ================================ ! Fluids Physical Parameters ======================================= do i = 1, num_fluids - call s_int_to_str(i,iStr) + call s_int_to_str(i, iStr) if (fluid_pp(i)%gamma /= dflt_real & .and. & fluid_pp(i)%gamma <= 0d0) then call s_mpi_abort('Unsupported value of '// & - 'fluid_pp('//trim(iStr)//')%'// & - 'gamma. Exiting ...') + 'fluid_pp('//trim(iStr)//')%'// & + 'gamma. Exiting ...') elseif (model_eqns == 1 & .and. & fluid_pp(i)%gamma /= dflt_real) then call s_mpi_abort('Unsupported combination '// & - 'of values of model_eqns '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'gamma. Exiting ...') + 'of values of model_eqns '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'gamma. Exiting ...') elseif ((i <= num_fluids + bub_fac .and. fluid_pp(i)%gamma <= 0d0) & .or. & (i > num_fluids + bub_fac .and. fluid_pp(i)%gamma /= dflt_real)) & then call s_mpi_abort('Unsupported combination '// & - 'of values of num_fluids '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'gamma. Exiting ...') + 'of values of num_fluids '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'gamma. Exiting ...') elseif (fluid_pp(i)%pi_inf /= dflt_real & .and. & fluid_pp(i)%pi_inf < 0d0) then call s_mpi_abort('Unsupported value of '// & - 'fluid_pp('//trim(iStr)//')%'// & - 'pi_inf. Exiting ...') + 'fluid_pp('//trim(iStr)//')%'// & + 'pi_inf. Exiting ...') elseif (model_eqns == 1 & .and. & fluid_pp(i)%pi_inf /= dflt_real) then call s_mpi_abort('Unsupported combination '// & - 'of values of model_eqns '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'pi_inf. Exiting ...') + 'of values of model_eqns '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'pi_inf. Exiting ...') elseif ((i <= num_fluids + bub_fac .and. fluid_pp(i)%pi_inf < 0d0) & .or. & (i > num_fluids + bub_fac .and. fluid_pp(i)%pi_inf /= dflt_real)) & then call s_mpi_abort('Unsupported combination '// & - 'of values of num_fluids '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'pi_inf. Exiting ...') - elseif ( fluid_pp(i)%cv < 0d0 ) then - call s_mpi_abort('Unsupported value of '// & - 'fluid_pp('//trim(iStr)//')%'// & - 'cv. Make sure cv is positive. Exiting ...') + 'of values of num_fluids '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'pi_inf. Exiting ...') + elseif (fluid_pp(i)%cv < 0d0) then + call s_mpi_abort('Unsupported value of '// & + 'fluid_pp('//trim(iStr)//')%'// & + 'cv. Make sure cv is positive. Exiting ...') end if do j = 1, 2 - call s_int_to_str(j,jStr) + call s_int_to_str(j, jStr) if (fluid_pp(i)%Re(j) /= dflt_real & .and. & fluid_pp(i)%Re(j) <= 0d0) then call s_mpi_abort('Unsupported value of '// & - 'fluid_pp('//trim(iStr)//')%'// & - 'Re('//trim(jStr)//'). Exiting ...') + 'fluid_pp('//trim(iStr)//')%'// & + 'Re('//trim(jStr)//'). Exiting ...') end if if (model_eqns == 1 & .and. & fluid_pp(i)%Re(j) /= dflt_real) then call s_mpi_abort('Unsupported combination '// & - 'of values of model_eqns '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'Re('//trim(jStr)//'). Exiting ...') + 'of values of model_eqns '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'Re('//trim(jStr)//'). Exiting ...') end if if (i > num_fluids & .and. & fluid_pp(i)%Re(j) /= dflt_real) then call s_mpi_abort('Unsupported combination '// & - 'of values of num_fluids '// & - 'and fluid_pp('//trim(iStr)//')%'// & - 'Re('//trim(jStr)//'). Exiting ...') + 'of values of num_fluids '// & + 'and fluid_pp('//trim(iStr)//')%'// & + 'Re('//trim(jStr)//'). Exiting ...') end if if (weno_order == 1 & .and. & - (weno_avg .neqv. .true.) & + (weno_avg .neqv. .true.) & .and. & - fluid_pp(i)%Re(j) /= dflt_real ) then + fluid_pp(i)%Re(j) /= dflt_real) then call s_mpi_abort('Unsupported combination '// & - 'of values of weno_order, '// & - 'weno_avg and fluid_pp('//trim(iStr)//')%'// & - 'Re('//trim(jStr)//'). Exiting ...') - end if + 'of values of weno_order, '// & + 'weno_avg and fluid_pp('//trim(iStr)//')%'// & + 'Re('//trim(jStr)//'). Exiting ...') + end if end do @@ -410,4 +410,4 @@ contains end subroutine s_check_inputs -end module m_checker +end module m_checker diff --git a/src/simulation/m_compute_cbc.fpp b/src/simulation/m_compute_cbc.fpp index b56a73dd7..4b3a98528 100644 --- a/src/simulation/m_compute_cbc.fpp +++ b/src/simulation/m_compute_cbc.fpp @@ -13,13 +13,13 @@ module m_compute_cbc implicit none private; public :: s_compute_slip_wall_L, & - s_compute_nonreflecting_subsonic_buffer_L, & - s_compute_nonreflecting_subsonic_inflow_L, & - s_compute_nonreflecting_subsonic_outflow_L, & - s_compute_force_free_subsonic_outflow_L, & - s_compute_constant_pressure_subsonic_outflow_L, & - s_compute_supersonic_inflow_L, & - s_compute_supersonic_outflow_L + s_compute_nonreflecting_subsonic_buffer_L, & + s_compute_nonreflecting_subsonic_inflow_L, & + s_compute_nonreflecting_subsonic_outflow_L, & + s_compute_force_free_subsonic_outflow_L, & + s_compute_constant_pressure_subsonic_outflow_L, & + s_compute_supersonic_inflow_L, & + s_compute_supersonic_outflow_L contains @@ -28,7 +28,7 @@ contains !! the normal component of velocity is zero at all times, !! while the transverse velocities may be nonzero. subroutine s_compute_slip_wall_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - !$acc routine seq + !$acc routine seq real(kind(0d0)), dimension(3), intent(IN) :: lambda real(kind(0d0)), dimension(num_fluids), intent(IN) :: mf, dalpha_rho_ds, dadv_ds real(kind(0d0)), dimension(num_dims), intent(IN) :: dvel_ds @@ -52,7 +52,7 @@ contains !! buffer reduces the amplitude of any reflections caused by !! outgoing waves. subroutine s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - !$acc routine seq + !$acc routine seq real(kind(0d0)), dimension(3), intent(IN) :: lambda real(kind(0d0)), dimension(num_fluids), intent(IN) :: mf, dalpha_rho_ds, dadv_ds real(kind(0d0)), dimension(num_dims), intent(IN) :: dvel_ds @@ -62,25 +62,25 @@ contains integer :: i !< Generic loop iterator L(1) = (5d-1 - 5d-1*sign(1d0, lambda(1)))*lambda(1) & - *(dpres_ds - rho*c*dvel_ds(dir_idx(1))) + *(dpres_ds - rho*c*dvel_ds(dir_idx(1))) do i = 2, momxb L(i) = (5d-1 - 5d-1*sign(1d0, lambda(2)))*lambda(2) & - *(c*c*dalpha_rho_ds(i - 1) - mf(i - 1)*dpres_ds) + *(c*c*dalpha_rho_ds(i - 1) - mf(i - 1)*dpres_ds) end do do i = momxb + 1, momxe L(i) = (5d-1 - 5d-1*sign(1d0, lambda(2)))*lambda(2) & - *(dvel_ds(dir_idx(i - contxe))) + *(dvel_ds(dir_idx(i - contxe))) end do do i = E_idx, advxe - 1 L(i) = (5d-1 - 5d-1*sign(1d0, lambda(2)))*lambda(2) & - *(dadv_ds(i - momxe)) + *(dadv_ds(i - momxe)) end do L(advxe) = (5d-1 - 5d-1*sign(1d0, lambda(3)))*lambda(3) & - *(dpres_ds + rho*c*dvel_ds(dir_idx(1))) + *(dpres_ds + rho*c*dvel_ds(dir_idx(1))) end subroutine s_compute_nonreflecting_subsonic_buffer_L ! ------------- @@ -89,7 +89,7 @@ contains !! CBC assumes an incoming flow and reduces the amplitude of !! any reflections caused by outgoing waves. subroutine s_compute_nonreflecting_subsonic_inflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - !$acc routine seq + !$acc routine seq real(kind(0d0)), dimension(3), intent(IN) :: lambda real(kind(0d0)), dimension(num_fluids), intent(IN) :: mf, dalpha_rho_ds, dadv_ds real(kind(0d0)), dimension(num_dims), intent(IN) :: dvel_ds @@ -111,7 +111,7 @@ contains !! subsonic CBC presumes an outgoing flow and reduces the !! amplitude of any reflections caused by outgoing waves. subroutine s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - !$acc routine seq + !$acc routine seq real(kind(0d0)), dimension(3), intent(IN) :: lambda real(kind(0d0)), dimension(num_fluids), intent(IN) :: mf, dalpha_rho_ds, dadv_ds real(kind(0d0)), dimension(num_dims), intent(IN) :: dvel_ds @@ -147,7 +147,7 @@ contains !! at the boundary is simply advected outward at the fluid !! velocity. subroutine s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - !$acc routine seq + !$acc routine seq real(kind(0d0)), dimension(3), intent(IN) :: lambda real(kind(0d0)), dimension(num_fluids), intent(IN) :: mf, dalpha_rho_ds, dadv_ds real(kind(0d0)), dimension(num_dims), intent(IN) :: dvel_ds @@ -179,7 +179,7 @@ contains !! subsonic outflow maintains a fixed pressure at the CBC !! boundary in absence of any transverse effects. subroutine s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - !$acc routine seq + !$acc routine seq real(kind(0d0)), dimension(3), intent(IN) :: lambda real(kind(0d0)), dimension(num_fluids), intent(IN) :: mf, dalpha_rho_ds, dadv_ds real(kind(0d0)), dimension(num_dims), intent(IN) :: dvel_ds @@ -212,7 +212,7 @@ contains !! transverse terms may generate a time dependence at the !! inflow boundary. subroutine s_compute_supersonic_inflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - !$acc routine seq + !$acc routine seq real(kind(0d0)), dimension(3), intent(IN) :: lambda real(kind(0d0)), dimension(num_fluids), intent(IN) :: mf, dalpha_rho_ds, dadv_ds real(kind(0d0)), dimension(num_dims), intent(IN) :: dvel_ds @@ -232,7 +232,7 @@ contains !! flow evolution at the boundary is determined completely !! by the interior data. subroutine s_compute_supersonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) ! -------------- - !$acc routine seq + !$acc routine seq real(kind(0d0)), dimension(3), intent(IN) :: lambda real(kind(0d0)), dimension(num_fluids), intent(IN) :: mf, dalpha_rho_ds, dadv_ds real(kind(0d0)), dimension(num_dims), intent(IN) :: dvel_ds diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index 71774e5aa..d6ea41516 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -71,14 +71,14 @@ module m_data_output real(kind(0d0)), allocatable, dimension(:, :, :) :: ccfl_sf !< CCFL stability criterion real(kind(0d0)), allocatable, dimension(:, :, :) :: Rc_sf !< Rc stability criterion -!$acc declare create(icfl_sf, vcfl_sf, ccfl_sf, Rc_sf) + !$acc declare create(icfl_sf, vcfl_sf, ccfl_sf, Rc_sf) real(kind(0d0)) :: icfl_max_loc, icfl_max_glb !< ICFL stability extrema on local and global grids real(kind(0d0)) :: vcfl_max_loc, vcfl_max_glb !< VCFL stability extrema on local and global grids real(kind(0d0)) :: ccfl_max_loc, ccfl_max_glb !< CCFL stability extrema on local and global grids real(kind(0d0)) :: Rc_min_loc, Rc_min_glb !< Rc stability extrema on local and global grids -!$acc declare create(icfl_max_loc, icfl_max_glb, vcfl_max_loc, vcfl_max_glb, ccfl_max_loc, ccfl_max_glb, Rc_min_loc, Rc_min_glb) + !$acc declare create(icfl_max_loc, icfl_max_glb, vcfl_max_loc, vcfl_max_glb, ccfl_max_loc, ccfl_max_glb, Rc_min_loc, Rc_min_glb) !> @name ICFL, VCFL, CCFL and Rc stability criteria extrema over all the time-steps !> @{ @@ -247,7 +247,7 @@ contains !! Modified dtheta accounting for Fourier filtering in azimuthal direction. ! Computing Stability Criteria at Current Time-step ================ -!$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho, vel, alpha, Re) + !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho, vel, alpha, Re) do l = 0, p do k = 0, n do j = 0, m @@ -330,7 +330,7 @@ contains !2D icfl_sf(j, k, l) = dt/min(dx(j)/(abs(vel(1)) + c), & dy(k)/(abs(vel(2)) + c)) - + if (any(Re_size > 0)) then vcfl_sf(j, k, l) = maxval(dt/Re/rho)/min(dx(j), dy(k))**2d0 @@ -415,14 +415,14 @@ contains call s_mpi_abort('ICFL is NaN. Exiting ...') elseif (icfl_max_glb > 1d0) then print *, 'icfl', icfl_max_glb - call s_mpi_abort('ICFL is greater than 1.0. Exiting ...') + call s_mpi_abort('ICFL is greater than 1.0. Exiting ...') end if if (vcfl_max_glb /= vcfl_max_glb) then call s_mpi_abort('VCFL is NaN. Exiting ...') elseif (vcfl_max_glb > 1d0) then print *, 'vcfl', vcfl_max_glb - call s_mpi_abort('VCFL is greater than 1.0. Exiting ...') + call s_mpi_abort('VCFL is greater than 1.0. Exiting ...') end if end if @@ -452,7 +452,7 @@ contains character(LEN=15) :: FMT - integer :: i, j, k, l, ii , r!< Generic loop iterators + integer :: i, j, k, l, ii, r!< Generic loop iterators real(kind(0d0)), dimension(nb) :: nRtmp !< Temporary bubble concentration real(kind(0d0)) :: nbub, nR3, vftmp !< Temporary bubble number density @@ -516,11 +516,11 @@ contains write (2) q_cons_vf(i)%sf(0:m, 0:n, 0:p); close (2) end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A)') trim(t_step_dir)//'/pb', & - sys_size + (i-1)*nnode + r, '.dat' + sys_size + (i - 1)*nnode + r, '.dat' open (2, FILE=trim(file_path), & FORM='unformatted', & @@ -533,7 +533,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A)') trim(t_step_dir)//'/mv', & - sys_size + (i-1)*nnode + r, '.dat' + sys_size + (i - 1)*nnode + r, '.dat' open (2, FILE=trim(file_path), & FORM='unformatted', & @@ -547,7 +547,7 @@ contains gamma = fluid_pp(1)%gamma lit_gamma = 1d0/fluid_pp(1)%gamma + 1d0 pi_inf = fluid_pp(1)%pi_inf - qv = fluid_pp(1)%qv + qv = fluid_pp(1)%qv if (precision == 1) then FMT = "(2F30.3)" @@ -569,7 +569,7 @@ contains !$acc update host(q_prim_vf(i)%sf(:,:,:)) end do ! q_prim_vf(bubxb) stores the value of nb needed in riemann solvers, so replace with true primitive value (=1d0) - if(qbmm) then + if (qbmm) then q_prim_vf(bubxb)%sf = 1d0 end if end if @@ -606,10 +606,10 @@ contains close (2) end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -620,7 +620,7 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -652,10 +652,10 @@ contains close (2) end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -668,7 +668,7 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -728,10 +728,10 @@ contains close (2) end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -746,7 +746,7 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -776,7 +776,7 @@ contains ) then write (2, FMT) x_cb(j), y_cb(k), z_cb(l), q_cons_vf(i)%sf(j, k, l) else - write (2, FMT) x_cb(j), y_cb(k), z_cb(l), q_prim_vf(i)%sf(j, k, l) + write (2, FMT) x_cb(j), y_cb(k), z_cb(l), q_prim_vf(i)%sf(j, k, l) end if end do write (2, *) @@ -818,7 +818,7 @@ contains character(LEN=path_len + 2*name_len) :: file_loc logical :: file_exist, dir_check - character(len = 10) :: t_step_string + character(len=10) :: t_step_string integer :: i !< Generic loop iterator @@ -835,7 +835,7 @@ contains call s_create_directory(trim(file_loc)) end if call s_mpi_barrier() - call DelayFileAccess (proc_rank) + call DelayFileAccess(proc_rank) ! Initialize MPI data I/O @@ -849,7 +849,7 @@ contains call MPI_FILE_DELETE(file_loc, mpi_info_int, ierr) end if call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + mpi_info_int, ifile, ierr) ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) @@ -872,14 +872,14 @@ contains MPI_DOUBLE_PRECISION, status, ierr) end do !Write pb and mv for non-polytropic qbmm - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & MPI_DOUBLE_PRECISION, status, ierr) end do - end if + end if else do i = 1, sys_size !TODO: check if correct (sys_size var_MOK = int(i, MPI_OFFSET_KIND) @@ -903,7 +903,7 @@ contains call MPI_FILE_DELETE(file_loc, mpi_info_int, ierr) end if call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + mpi_info_int, ifile, ierr) ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) @@ -926,12 +926,12 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & MPI_DOUBLE_PRECISION, status, ierr) end do !Write pb and mv for non-polytropic qbmm - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) @@ -939,11 +939,11 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & MPI_DOUBLE_PRECISION, status, ierr) end do - end if + end if else do i = 1, sys_size !TODO: check if correct (sys_size var_MOK = int(i, MPI_OFFSET_KIND) @@ -952,7 +952,7 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & MPI_DOUBLE_PRECISION, status, ierr) end do @@ -965,7 +965,6 @@ contains end subroutine s_write_parallel_data_files ! --------------------------- - !> This writes a formatted data file for the flow probe information !! @param t_step Current time-step !! @param q_cons_vf Conservative variables @@ -1074,7 +1073,7 @@ contains l = 0 ! Computing/Sharing necessary state variables - if(hypoelasticity) then + if (hypoelasticity) then call s_convert_to_mixture_variables(q_cons_vf, j - 2, k, l, & rho, gamma, pi_inf, qv, & Re, G, fluid_pp(:)%G) @@ -1086,7 +1085,7 @@ contains vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k, l)/rho end do - if(hypoelasticity) then + if (hypoelasticity) then call s_compute_pressure( & q_cons_vf(1)%sf(j - 2, k, l), & q_cons_vf(alf_idx)%sf(j - 2, k, l), & @@ -1157,7 +1156,7 @@ contains ! Compute mixture sound Speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, & - ((gamma + 1d0)*pres + pi_inf)/rho, alpha, 0d0, c) + ((gamma + 1d0)*pres + pi_inf)/rho, alpha, 0d0, c) accel = accel_mag(j - 2, k, l) end if @@ -1179,7 +1178,7 @@ contains l = 0 ! Computing/Sharing necessary state variables - call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l, & + call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l, & rho, gamma, pi_inf, qv, & Re, G, fluid_pp(:)%G) do s = 1, num_dims @@ -1224,7 +1223,7 @@ contains ! Compute mixture sound speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, & - ((gamma + 1d0)*pres + pi_inf)/rho, alpha, 0d0, c) + ((gamma + 1d0)*pres + pi_inf)/rho, alpha, 0d0, c) accel = accel_mag(j - 2, k - 2, l) end if @@ -1261,11 +1260,11 @@ contains end do call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k - 2, l - 2), & - 0d0, 0.5d0*rho*dot_product(vel, vel), pi_inf, gamma, rho, qv, pres) + 0d0, 0.5d0*rho*dot_product(vel, vel), pi_inf, gamma, rho, qv, pres) ! Compute mixture sound speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, & - ((gamma + 1d0)*pres + pi_inf)/rho, alpha, 0d0, c) + ((gamma + 1d0)*pres + pi_inf)/rho, alpha, 0d0, c) accel = accel_mag(j - 2, k - 2, l - 2) end if @@ -1616,17 +1615,16 @@ contains integer :: i !< Generic loop iterator - ! Allocating/initializing ICFL, VCFL, CCFL and Rc stability criteria @:ALLOCATE(icfl_sf(0:m, 0:n, 0:p)) icfl_max = 0d0 - + if (any(Re_size > 0)) then @:ALLOCATE(vcfl_sf(0:m, 0:n, 0:p)) @:ALLOCATE(Rc_sf (0:m, 0:n, 0:p)) - + vcfl_max = 0d0 - Rc_min = 1d3 + Rc_min = 1d3 end if ! Associating the procedural pointer to the appropriate subroutine diff --git a/src/simulation/m_derived_variables.f90 b/src/simulation/m_derived_variables.f90 index 8e02c49f1..459193a5b 100644 --- a/src/simulation/m_derived_variables.f90 +++ b/src/simulation/m_derived_variables.f90 @@ -26,9 +26,9 @@ module m_derived_variables implicit none private; public :: s_initialize_derived_variables_module, & - s_initialize_derived_variables, & - s_compute_derived_variables, & - s_finalize_derived_variables_module + s_initialize_derived_variables, & + s_compute_derived_variables, & + s_finalize_derived_variables_module !> @name Finite-difference coefficients !! Finite-difference (fd) coefficients in x-, y- and z-coordinate directions. @@ -94,16 +94,16 @@ subroutine s_initialize_derived_variables() ! ----------------------------- ! Computing centered finite difference coefficients call s_compute_finite_difference_coefficients(m, x_cc, fd_coeff_x, buff_size, & - fd_number, fd_order) + fd_number, fd_order) if (n > 0) then call s_compute_finite_difference_coefficients(n, y_cc, fd_coeff_y, buff_size, & - fd_number, fd_order) + fd_number, fd_order) end if if (p > 0) then call s_compute_finite_difference_coefficients(p, z_cc, fd_coeff_z, buff_size, & - fd_number, fd_order) + fd_number, fd_order) end if end if @@ -235,7 +235,7 @@ subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, & end do end do - ! Computing the acceleration component in the y-coordinate direction + ! Computing the acceleration component in the y-coordinate direction elseif (i == 2) then do l = 0, p do k = 0, n @@ -278,7 +278,7 @@ subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, & end do end do - ! Computing the acceleration component in the z-coordinate direction + ! Computing the acceleration component in the z-coordinate direction else do l = 0, p do k = 0, n @@ -316,7 +316,6 @@ subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, & end subroutine s_derive_acceleration_component ! -------------------------- - !> Deallocation procedures for the module subroutine s_finalize_derived_variables_module() ! ------------------- @@ -328,11 +327,11 @@ subroutine s_finalize_derived_variables_module() ! ------------------- end if if (probe_wrt) then - deallocate(accel_mag, x_accel) + deallocate (accel_mag, x_accel) if (n > 0) then - deallocate(y_accel) + deallocate (y_accel) if (p > 0) then - deallocate(z_accel) + deallocate (z_accel) end if end if end if diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index d3c1d8173..db45a2993 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -46,7 +46,7 @@ module m_fftw #if defined(MFC_OpenACC) && defined(__PGI) !$acc declare create(real_size, cmplx_size, x_size, batch_size) - real(kind(0d0)), allocatable :: data_real_gpu(:) + real(kind(0d0)), allocatable :: data_real_gpu(:) complex(kind(0d0)), allocatable :: data_cmplx_gpu(:) complex(kind(0d0)), allocatable :: data_fltr_cmplx_gpu(:) !$acc declare create(data_real_gpu, data_cmplx_gpu, data_fltr_cmplx_gpu) @@ -84,13 +84,13 @@ contains #if defined(MFC_OpenACC) && defined(__PGI) rank = 1; istride = 1; ostride = 1 - allocate(cufft_size(1:rank), iembed(1:rank), oembed(1:rank)) + allocate (cufft_size(1:rank), iembed(1:rank), oembed(1:rank)) cufft_size(1) = real_size; iembed(1) = 0 oembed(1) = 0 - !$acc update device(real_size, cmplx_size, x_size, sys_size, batch_size) +!$acc update device(real_size, cmplx_size, x_size, sys_size, batch_size) #else ! Allocate input and output DFT data sizes fftw_real_data = fftw_alloc_real(int(real_size, c_size_t)) @@ -134,7 +134,7 @@ contains #if defined(MFC_OpenACC) && defined(__PGI) -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do k = 1, sys_size do j = 0, m do l = 1, cmplx_size @@ -143,7 +143,7 @@ contains end do end do -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do k = 1, sys_size do j = 0, m do l = 0, p @@ -152,30 +152,30 @@ contains end do end do -!$acc host_data use_device(data_real_gpu, data_cmplx_gpu) + !$acc host_data use_device(data_real_gpu, data_cmplx_gpu) ierr = cufftExecD2Z(fwd_plan_gpu, data_real_gpu, data_cmplx_gpu) -!$acc end host_data + !$acc end host_data Nfq = 3 -!$acc parallel loop collapse(3) gang vector default(present) firstprivate(Nfq) + !$acc parallel loop collapse(3) gang vector default(present) firstprivate(Nfq) do k = 1, sys_size do j = 0, m do l = 1, Nfq - data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) + data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) end do end do end do -!$acc host_data use_device(data_real_gpu, data_fltr_cmplx_gpu) + !$acc host_data use_device(data_real_gpu, data_fltr_cmplx_gpu) ierr = cufftExecZ2D(bwd_plan_gpu, data_fltr_cmplx_gpu, data_real_gpu) -!$acc end host_data + !$acc end host_data -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do k = 1, sys_size do j = 0, m do l = 0, p - data_real_gpu(l + j*real_size + 1 + (k-1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k-1)*real_size*x_size)/REAL(real_size,KIND(0d0)) + data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size)/real(real_size, kind(0d0)) q_cons_vf(k)%sf(j, 0, l) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) end do end do @@ -183,7 +183,7 @@ contains do i = 1, fourier_rings -!$acc parallel loop collapse(3) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do k = 1, sys_size do j = 0, m do l = 1, cmplx_size @@ -192,7 +192,7 @@ contains end do end do -!$acc parallel loop collapse(3) gang vector default(present) firstprivate(i) + !$acc parallel loop collapse(3) gang vector default(present) firstprivate(i) do k = 1, sys_size do j = 0, m do l = 0, p @@ -201,30 +201,30 @@ contains end do end do -!$acc host_data use_device(data_real_gpu, data_cmplx_gpu) + !$acc host_data use_device(data_real_gpu, data_cmplx_gpu) ierr = cufftExecD2Z(fwd_plan_gpu, data_real_gpu, data_cmplx_gpu) -!$acc end host_data + !$acc end host_data Nfq = min(floor(2d0*real(i, kind(0d0))*pi), cmplx_size) -!$acc parallel loop collapse(3) gang vector default(present) firstprivate(Nfq) + !$acc parallel loop collapse(3) gang vector default(present) firstprivate(Nfq) do k = 1, sys_size do j = 0, m do l = 1, Nfq - data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) + data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) end do end do end do -!$acc host_data use_device(data_real_gpu, data_fltr_cmplx_gpu) + !$acc host_data use_device(data_real_gpu, data_fltr_cmplx_gpu) ierr = cufftExecZ2D(bwd_plan_gpu, data_fltr_cmplx_gpu, data_real_gpu) -!$acc end host_data + !$acc end host_data -!$acc parallel loop collapse(3) gang vector default(present) firstprivate(i) + !$acc parallel loop collapse(3) gang vector default(present) firstprivate(i) do k = 1, sys_size do j = 0, m do l = 0, p - data_real_gpu(l + j*real_size + 1 + (k-1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k-1)*real_size*x_size)/REAL(real_size,KIND(0d0)) + data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size)/real(real_size, kind(0d0)) q_cons_vf(k)%sf(j, i, l) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) end do end do diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 494c209cf..18b3702c0 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -55,7 +55,7 @@ module m_global_parameters logical :: cyl_coord integer :: grid_geometry !> @} -!$acc declare create(cyl_coord, grid_geometry) + !$acc declare create(cyl_coord, grid_geometry) !> @name Cell-boundary (CB) locations in the x-, y- and z-directions, respectively !> @{ @@ -72,10 +72,10 @@ module m_global_parameters !> @{ real(kind(0d0)), target, allocatable, dimension(:) :: dx, dy, dz !> @} - + real(kind(0d0)) :: dt !< Size of the time-step -!$acc declare create(x_cb, y_cb, z_cb, x_cc, y_cc, z_cc, dx, dy, dz, dt, m, n, p) + !$acc declare create(x_cb, y_cb, z_cb, x_cc, y_cc, z_cc, dx, dy, dz, dt, m, n, p) !> @name Starting time-step iteration, stopping time-step iteration and the number !! of time-step iterations between successive solution backups, respectively @@ -130,7 +130,7 @@ module m_global_parameters !$acc declare create(num_dims, weno_polyn, weno_order) #:endif -!$acc declare create(mpp_lim, num_fluids, model_eqns, mixture_err, alt_soundspeed, avg_state, mapped_weno, mp_weno, weno_eps, hypoelasticity, relax, palpha_eps,ptgalpha_eps) + !$acc declare create(mpp_lim, num_fluids, model_eqns, mixture_err, alt_soundspeed, avg_state, mapped_weno, mp_weno, weno_eps, hypoelasticity, relax, palpha_eps,ptgalpha_eps) !> @name Boundary conditions (BC) in the x-, y- and z-directions, respectively !> @{ @@ -173,7 +173,7 @@ module m_global_parameters type(int_bounds_info) :: stress_idx !< Indexes of first and last shear stress eqns. !> @} -!$acc declare create(bub_idx) + !$acc declare create(bub_idx) !> @name The number of fluids, along with their identifying indexes, respectively, !! for which viscous effects, e.g. the shear and/or the volume Reynolds (Re) @@ -183,7 +183,7 @@ module m_global_parameters integer, allocatable, dimension(:, :) :: Re_idx !> @{ -!$acc declare create(Re_size, Re_idx) + !$acc declare create(Re_size, Re_idx) ! The WENO average (WA) flag regulates whether the calculation of any cell- ! average spatial derivatives is carried out in each cell by utilizing the @@ -191,11 +191,11 @@ module m_global_parameters ! values or simply, the unaltered left and right, WENO-reconstructed, cell- ! boundary values. !> @{ - REAL(KIND(0d0)) :: wa_flg + real(kind(0d0)) :: wa_flg !> @{ -!$acc declare create(wa_flg) - + !$acc declare create(wa_flg) + !> @name The coordinate direction indexes and flags (flg), respectively, for which !! the configurations will be determined with respect to a working direction !! and that will be used to isolate the contributions, in that direction, in @@ -206,7 +206,7 @@ module m_global_parameters integer, dimension(3) :: dir_idx_tau !!used for hypoelasticity=true !> @} -!$acc declare create(dir_idx, dir_flg, dir_idx_tau) + !$acc declare create(dir_idx, dir_flg, dir_idx_tau) integer :: buff_size !< !! The number of cells that are necessary to be able to store enough boundary @@ -215,8 +215,7 @@ module m_global_parameters integer :: startx, starty, startz - -!$acc declare create(sys_size, buff_size, startx, starty, startz, E_idx, gamma_idx, pi_inf_idx, alf_idx, stress_idx) + !$acc declare create(sys_size, buff_size, startx, starty, startz, E_idx, gamma_idx, pi_inf_idx, alf_idx, stress_idx) ! END: Simulation Algorithm Parameters ===================================== @@ -250,7 +249,7 @@ module m_global_parameters !> @{ real(kind(0d0)) :: rhoref, pref !> @} -!$acc declare create(rhoref, pref) + !$acc declare create(rhoref, pref) !> @name Bubble modeling !> @{ @@ -286,12 +285,12 @@ module m_global_parameters !$acc declare create(nb) #:endif -!$acc declare create(R0ref, Ca, Web, Re_inv, weight, R0, V0, bubbles, polytropic, polydisperse, qbmm, nmomsp, nmomtot, R0_type, ptil, bubble_model, thermal, poly_sigma) + !$acc declare create(R0ref, Ca, Web, Re_inv, weight, R0, V0, bubbles, polytropic, polydisperse, qbmm, nmomsp, nmomtot, R0_type, ptil, bubble_model, thermal, poly_sigma) type(scalar_field), allocatable, dimension(:) :: mom_sp type(scalar_field), allocatable, dimension(:, :, :) :: mom_3d !> @} -!$acc declare create(mom_sp, mom_3d) + !$acc declare create(mom_sp, mom_3d) !> @name Physical bubble parameters (see Ando 2010, Preston 2007) !> @{ @@ -302,29 +301,26 @@ module m_global_parameters real(kind(0d0)) :: gamma_m, gamma_n, mu_n real(kind(0d0)) :: gam !> @} -!$acc declare create(R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, pv, M_n, M_v, k_n, k_v, pb0, mass_n0, mass_v0, Pe_T, Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN , mul0, ss, gamma_v, mu_v, gamma_m, gamma_n, mu_n, gam) + !$acc declare create(R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, pv, M_n, M_v, k_n, k_v, pb0, mass_n0, mass_v0, Pe_T, Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN , mul0, ss, gamma_v, mu_v, gamma_m, gamma_n, mu_n, gam) !> @name Acoustic monopole parameters !> @{ logical :: monopole !< Monopole switch type(mono_parameters), dimension(num_probes_max) :: mono !< Monopole parameters integer :: num_mono !< Number of monopoles !> @} -!$acc declare create(monopole, mono, num_mono) - - + !$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) + 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, gs_min, pi_infs, ps_inf, cvs, qvs, qvps !$acc declare create(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps) - real(kind(0d0)) :: mytime !< Current simulation time real(kind(0d0)) :: finaltime !< Final simulation time @@ -401,9 +397,9 @@ contains do i = 1, num_fluids_max fluid_pp(i)%gamma = dflt_real fluid_pp(i)%pi_inf = dflt_real - fluid_pp(i)%cv = 0d0 - fluid_pp(i)%qv = 0d0 - fluid_pp(i)%qvp = 0d0 + fluid_pp(i)%cv = 0d0 + fluid_pp(i)%qv = 0d0 + fluid_pp(i)%qvp = 0d0 fluid_pp(i)%Re(:) = dflt_real fluid_pp(i)%mul0 = dflt_real fluid_pp(i)%ss = dflt_real @@ -491,7 +487,7 @@ contains !! other procedures that are necessary to setup the module. subroutine s_initialize_global_parameters_module() ! ------------------- - integer :: i, j, k + integer :: i, j, k integer :: fac type(int_bounds_info) :: ix, iy, iz @@ -499,8 +495,8 @@ contains #:if not MFC_CASE_OPTIMIZATION ! Determining the degree of the WENO polynomials weno_polyn = (weno_order - 1)/2 -!$acc update device(weno_polyn) -!$acc update device(nb) + !$acc update device(weno_polyn) + !$acc update device(nb) #:endif ! Initializing the number of fluids for which viscous effects will @@ -510,7 +506,6 @@ contains ! interfaces will be computed Re_size = 0 - ! Gamma/Pi_inf Model =============================================== if (model_eqns == 1) then @@ -626,7 +621,7 @@ contains end if !Initialize pref,rhoref for polytropic qbmm (done in s_initialize_nonpoly for non-polytropic) - if(.not. qbmm) then + if (.not. qbmm) then if (polytropic) then rhoref = 1.d0 pref = 1.d0 @@ -634,17 +629,17 @@ contains end if !Initialize pb0, pv, pref, rhoref for polytropic qbmm (done in s_initialize_nonpoly for non-polytropic) - if(qbmm) then - if(polytropic) then - pv = fluid_pp(1)%pv - pv = pv / pref + if (qbmm) then + if (polytropic) then + pv = fluid_pp(1)%pv + pv = pv/pref @:ALLOCATE(pb0(nb)) - if(Web == dflt_real) then + if (Web == dflt_real) then pb0 = pref - pb0 = pb0 / pref - pref = 1d0 + pb0 = pb0/pref + pref = 1d0 end if - rhoref = 1d0 + rhoref = 1d0 end if end if @@ -730,7 +725,7 @@ contains if (fluid_pp(i)%Re(1) > 0) Re_size(1) = Re_size(1) + 1 if (fluid_pp(i)%Re(2) > 0) Re_size(2) = Re_size(2) + 1 end do - + !$acc update device(Re_size) ! Bookkeeping the indexes of any viscous fluids and any pairs of @@ -757,33 +752,32 @@ contains end if ! END: Volume Fraction Model ======================================= - - if(qbmm .and. .not. polytropic) then + + if (qbmm .and. .not. polytropic) then allocate (MPI_IO_DATA%view(1:sys_size + 2*nb*4)) allocate (MPI_IO_DATA%var(1:sys_size + 2*nb*4)) else allocate (MPI_IO_DATA%view(1:sys_size)) - allocate (MPI_IO_DATA%var(1:sys_size)) + allocate (MPI_IO_DATA%var(1:sys_size)) end if do i = 1, sys_size allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) MPI_IO_DATA%var(i)%sf => null() end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*4 allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) MPI_IO_DATA%var(i)%sf => null() end do end if - ! Configuring the WENO average flag that will be used to regulate - ! whether any spatial derivatives are to computed in each cell by - ! using the arithmetic mean of left and right, WENO-reconstructed, - ! cell-boundary values or otherwise, the unaltered left and right, - ! WENO-reconstructed, cell-boundary values - wa_flg = 0d0; IF(weno_avg) wa_flg = 1d0 + ! whether any spatial derivatives are to computed in each cell by + ! using the arithmetic mean of left and right, WENO-reconstructed, + ! cell-boundary values or otherwise, the unaltered left and right, + ! WENO-reconstructed, cell-boundary values + wa_flg = 0d0; if (weno_avg) wa_flg = 1d0 !$acc update device(wa_flg) ! Determining the number of cells that are needed in order to store @@ -802,7 +796,7 @@ contains if (bubbles) then ix%beg = -buff_size; iy%beg = 0; iz%beg = 0 if (n > 0) then - iy%beg = -buff_size + iy%beg = -buff_size if (p > 0) then iz%beg = -buff_size end if @@ -828,7 +822,7 @@ contains startz = -buff_size end if -!$acc update device(startx, starty, startz) + !$acc update device(startx, starty, startz) if (cyl_coord .neqv. .true.) then ! Cartesian grid grid_geometry = 1 @@ -851,22 +845,19 @@ contains 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) + !$acc update device(momxb, momxe, advxb, advxe, contxb, contxe, bubxb, bubxe, intxb, intxe, sys_size, buff_size, E_idx, alf_idx, strxb, strxe) ! 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)) @:ALLOCATE(dx(-buff_size:m + buff_size)) - if (n == 0) return; - + if (n == 0) return; @:ALLOCATE(y_cb(-1 - buff_size:n + buff_size)) @:ALLOCATE(y_cc(-buff_size:n + buff_size)) @:ALLOCATE(dy(-buff_size:n + buff_size)) - if (p == 0) return; - + if (p == 0) return; @:ALLOCATE(z_cb(-1 - buff_size:p + buff_size)) @:ALLOCATE(z_cc(-buff_size:p + buff_size)) @:ALLOCATE(dz(-buff_size:p + buff_size)) @@ -918,11 +909,11 @@ contains ! Deallocating grid variables for the x-, y- and z-directions @:DEALLOCATE(x_cb, x_cc, dx) - - if (n == 0) return; + + if (n == 0) return; @:DEALLOCATE(y_cb, y_cc, dy) - if (p == 0) return; + if (p == 0) return; @:DEALLOCATE(z_cb, z_cc, dz) deallocate (proc_coords) @@ -938,6 +929,4 @@ contains end subroutine s_finalize_global_parameters_module ! ------------------- - - end module m_global_parameters diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index b955e5d89..c799cb367 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -20,7 +20,7 @@ module m_hypoelastic implicit none private; public :: s_initialize_hypoelastic_module, & - s_compute_hypoelastic_rhs + s_compute_hypoelastic_rhs real(kind(0d0)), allocatable, dimension(:) :: Gs !$acc declare create(Gs) @@ -32,7 +32,6 @@ module m_hypoelastic real(kind(0d0)), allocatable, dimension(:, :, :) :: rho_K_field, G_K_field !$acc declare create(rho_K_field, G_K_field) - contains @@ -51,7 +50,6 @@ contains end if end if - do i = 1, num_fluids Gs(i) = fluid_pp(i)%G end do @@ -66,7 +64,6 @@ contains !! @param rhs_vf rhs variables subroutine s_compute_hypoelastic_rhs(idir, q_prim_vf, rhs_vf) - type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(INOUT) :: rhs_vf integer, intent(IN) :: idir @@ -122,7 +119,7 @@ contains end do end do end do - + ! 3D if (ndirs == 3) then !$acc parallel loop collapse(3) gang vector default(present) @@ -166,20 +163,20 @@ contains end if !$acc parallel loop collapse(3) gang vector default(present) - do q = 0,p - do l = 0,n - do k = 0,m + do q = 0, p + do l = 0, n + do k = 0, m rho_K = 0d0; G_K = 0d0 do i = 1, num_fluids - rho_K = rho_K + q_prim_vf(i)%sf(k,l,q) !alpha_rho_K(1) - G_K = G_K + q_prim_vf(advxb-1+i)%sf(k,l,q)*Gs(i) !alpha_K(1) * Gs(1) + rho_K = rho_K + q_prim_vf(i)%sf(k, l, q) !alpha_rho_K(1) + G_K = G_K + q_prim_vf(advxb - 1 + i)%sf(k, l, q)*Gs(i) !alpha_K(1) * Gs(1) end do - rho_K_field(k,l,q) = rho_K - G_K_field(k,l,q) = G_K + rho_K_field(k, l, q) = rho_K + G_K_field(k, l, q) = G_K !TODO: take this out if not needed if (G_K < 1000) then - G_K_field(k,l,q) = 0 + G_K_field(k, l, q) = 0 end if end do end do @@ -191,111 +188,111 @@ contains do l = 0, n do k = 0, m rhs_vf(strxb)%sf(k, l, q) = & - rhs_vf(strxb)%sf(k,l,q) + rho_K_field(k,l,q) * & - ((4d0*G_K_field(k,l,q)/3d0) + & - q_prim_vf(strxb)%sf(k,l,q)) * & - du_dx(k,l,q) + rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)* & + ((4d0*G_K_field(k, l, q)/3d0) + & + q_prim_vf(strxb)%sf(k, l, q))* & + du_dx(k, l, q) end do end do end do - elseif(idir == 2) then + elseif (idir == 2) then !$acc parallel loop collapse(3) gang vector default(present) - do q = 0,p - do l = 0,n - do k = 0,m - rhs_vf(strxb)%sf(k,l,q) = rhs_vf(strxb)%sf(k,l,q) + rho_K_field(k,l,q) * & - (q_prim_vf(strxb+1)%sf(k,l,q) * du_dy(k,l,q) + & - q_prim_vf(strxb+1)%sf(k,l,q) * du_dy(k,l,q) - & - q_prim_vf( strxb )%sf(k,l,q) * dv_dy(k,l,q) - & - 2d0 * G_K_field(k,l,q) * (1d0/3d0) * dv_dy(k,l,q) ) - - rhs_vf(strxb+1)%sf(k,l,q) = rhs_vf(strxb+1)%sf(k,l,q) + rho_K_field(k,l,q) * & - (q_prim_vf(strxb+1)%sf(k,l,q) * du_dx(k,l,q) + & - q_prim_vf( strxb )%sf(k,l,q) * dv_dx(k,l,q) - & - q_prim_vf(strxb+1)%sf(k,l,q) * du_dx(k,l,q) + & - q_prim_vf(strxb+2)%sf(k,l,q) * du_dy(k,l,q) + & - q_prim_vf(strxb+1)%sf(k,l,q) * dv_dy(k,l,q) - & - q_prim_vf(strxb+1)%sf(k,l,q) * dv_dy(k,l,q) + & - 2d0 * G_K_field(k,l,q) * (1d0/2d0) * (du_dy(k,l,q) + & - dv_dx(k,l,q)) ) - - rhs_vf(strxb+2)%sf(k,l,q) = rhs_vf(strxb+2)%sf(k,l,q) + rho_K_field(k,l,q) * & - (q_prim_vf(strxb+1)%sf(k,l,q) * dv_dx(k,l,q) + & - q_prim_vf(strxb+1)%sf(k,l,q) * dv_dx(k,l,q) - & - q_prim_vf(strxb+2)%sf(k,l,q) * du_dx(k,l,q) + & - q_prim_vf(strxb+2)%sf(k,l,q) * dv_dy(k,l,q) + & - q_prim_vf(strxb+2)%sf(k,l,q) * dv_dy(k,l,q) - & - q_prim_vf(strxb+2)%sf(k,l,q) * dv_dy(k,l,q) + & - 2d0 * G_K_field(k,l,q)*(dv_dy(k,l,q) - (1d0/3d0) * & - (du_dx(k,l,q) + & - dv_dy(k,l,q))) ) + do q = 0, p + do l = 0, n + do k = 0, m + rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)* & + (q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy(k, l, q) + & + q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy(k, l, q) - & + q_prim_vf(strxb)%sf(k, l, q)*dv_dy(k, l, q) - & + 2d0*G_K_field(k, l, q)*(1d0/3d0)*dv_dy(k, l, q)) + + rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) + rho_K_field(k, l, q)* & + (q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx(k, l, q) + & + q_prim_vf(strxb)%sf(k, l, q)*dv_dx(k, l, q) - & + q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx(k, l, q) + & + q_prim_vf(strxb + 2)%sf(k, l, q)*du_dy(k, l, q) + & + q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy(k, l, q) - & + q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy(k, l, q) + & + 2d0*G_K_field(k, l, q)*(1d0/2d0)*(du_dy(k, l, q) + & + dv_dx(k, l, q))) + + rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) + rho_K_field(k, l, q)* & + (q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dx(k, l, q) + & + q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dx(k, l, q) - & + q_prim_vf(strxb + 2)%sf(k, l, q)*du_dx(k, l, q) + & + q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy(k, l, q) + & + q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy(k, l, q) - & + q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy(k, l, q) + & + 2d0*G_K_field(k, l, q)*(dv_dy(k, l, q) - (1d0/3d0)* & + (du_dx(k, l, q) + & + dv_dy(k, l, q)))) end do end do end do - elseif(idir == 3) then + elseif (idir == 3) then !$acc parallel loop collapse(3) gang vector default(present) do q = 0, p do l = 0, n do k = 0, m - rhs_vf(strxb)%sf(k,l,q) = rhs_vf(strxb)%sf(k,l,q) + rho_K_field(k,l,q) * & - (q_prim_vf(strxb+3)%sf(k,l,q) * du_dz(k,l,q) + & - q_prim_vf(strxb+3)%sf(k,l,q) * du_dz(k,l,q) - & - q_prim_vf( strxb )%sf(k,l,q) * dw_dz(k,l,q) - & - 2d0 * G_K_field(k,l,q) * (1d0/3d0) * dw_dz(k,l,q) ) - - rhs_vf(strxb+1)%sf(k,l,q) = rhs_vf(strxb+1)%sf(k,l,q) + rho_K_field(k,l,q) * & - (q_prim_vf(strxb+4)%sf(k,l,q) * du_dz(k,l,q) + & - q_prim_vf(strxb+3)%sf(k,l,q) * dv_dz(k,l,q) - & - q_prim_vf(strxb+1)%sf(k,l,q) * dw_dz(k,l,q)) - - rhs_vf(strxb+2)%sf(k,l,q) = rhs_vf(strxb+2)%sf(k,l,q) + rho_K_field(k,l,q) * & - (q_prim_vf(strxb+4)%sf(k,l,q) * dv_dz(k,l,q) + & - q_prim_vf(strxb+4)%sf(k,l,q) * dv_dz(k,l,q) - & - q_prim_vf(strxb+2)%sf(k,l,q) * dw_dz(k,l,q) - & - 2d0 * G_K_field(k,l,q) * (1d0/3d0) * dw_dz(k,l,q) ) - - rhs_vf(strxb+3)%sf(k,l,q) = rhs_vf(strxb+3)%sf(k,l,q) + rho_K_field(k,l,q) * & - (q_prim_vf(strxb+3)%sf(k,l,q) * du_dx(k,l,q) + & - q_prim_vf( strxb )%sf(k,l,q) * dw_dx(k,l,q) - & - q_prim_vf(strxb+3)%sf(k,l,q) * du_dx(k,l,q) + & - q_prim_vf(strxb+4)%sf(k,l,q) * du_dy(k,l,q) + & - q_prim_vf(strxb+1)%sf(k,l,q) * dw_dy(k,l,q) - & - q_prim_vf(strxb+3)%sf(k,l,q) * dv_dy(k,l,q)+ & - q_prim_vf(strxb+5)%sf(k,l,q) * du_dz(k,l,q) + & - q_prim_vf(strxb+3)%sf(k,l,q) * dw_dz(k,l,q) - & - q_prim_vf(strxb+3)%sf(k,l,q) * dw_dz(k,l,q) + & - 2d0 * G_K_field(k,l,q) * (1d0/2d0) * (du_dz(k,l,q) + & - dw_dx(k,l,q)) ) - - rhs_vf(strxb+4)%sf(k,l,q) = rhs_vf(strxb+4)%sf(k,l,q) + rho_K_field(k,l,q) * & - (q_prim_vf(strxb+3)%sf(k,l,q) * dv_dx(k,l,q) + & - q_prim_vf(strxb+1)%sf(k,l,q) * dw_dx(k,l,q) - & - q_prim_vf(strxb+4)%sf(k,l,q) * du_dx(k,l,q) + & - q_prim_vf(strxb+4)%sf(k,l,q) * dv_dy(k,l,q) + & - q_prim_vf(strxb+2)%sf(k,l,q) * dw_dy(k,l,q) - & - q_prim_vf(strxb+4)%sf(k,l,q) * dv_dy(k,l,q) + & - q_prim_vf(strxb+5)%sf(k,l,q) * dv_dz(k,l,q) + & - q_prim_vf(strxb+4)%sf(k,l,q) * dw_dz(k,l,q) - & - q_prim_vf(strxb+4)%sf(k,l,q) * dw_dz(k,l,q) + & - 2d0 * G_K_field(k,l,q) * (1d0/2d0) * (dv_dz(k,l,q) + & - dw_dy(k,l,q)) ) - - rhs_vf(strxe)%sf(k,l,q) = rhs_vf(strxe)%sf(k,l,q) + rho_K_field(k,l,q) * & - (q_prim_vf(strxe-2)%sf(k,l,q) * dw_dx(k,l,q) + & - q_prim_vf(strxe-2)%sf(k,l,q) * dw_dx(k,l,q) - & - q_prim_vf( strxe )%sf(k,l,q) * du_dx(k,l,q) + & - q_prim_vf(strxe-1)%sf(k,l,q) * dw_dy(k,l,q) + & - q_prim_vf(strxe-1)%sf(k,l,q) * dw_dy(k,l,q) - & - q_prim_vf( strxe )%sf(k,l,q) * dv_dy(k,l,q) + & - q_prim_vf( strxe )%sf(k,l,q) * dw_dz(k,l,q) + & - q_prim_vf( strxe )%sf(k,l,q) * dw_dz(k,l,q) - & - q_prim_vf( strxe )%sf(k,l,q) * dw_dz(k,l,q) + & - 2d0 * G_K_field(k,l,q) * (dw_dz(k,l,q) - (1d0/3d0) * & - (du_dx(k,l,q) + & - dv_dy(k,l,q) + & - dw_dz(k,l,q))) ) + rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)* & + (q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz(k, l, q) + & + q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz(k, l, q) - & + q_prim_vf(strxb)%sf(k, l, q)*dw_dz(k, l, q) - & + 2d0*G_K_field(k, l, q)*(1d0/3d0)*dw_dz(k, l, q)) + + rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) + rho_K_field(k, l, q)* & + (q_prim_vf(strxb + 4)%sf(k, l, q)*du_dz(k, l, q) + & + q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dz(k, l, q) - & + q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dz(k, l, q)) + + rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) + rho_K_field(k, l, q)* & + (q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz(k, l, q) + & + q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz(k, l, q) - & + q_prim_vf(strxb + 2)%sf(k, l, q)*dw_dz(k, l, q) - & + 2d0*G_K_field(k, l, q)*(1d0/3d0)*dw_dz(k, l, q)) + + rhs_vf(strxb + 3)%sf(k, l, q) = rhs_vf(strxb + 3)%sf(k, l, q) + rho_K_field(k, l, q)* & + (q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx(k, l, q) + & + q_prim_vf(strxb)%sf(k, l, q)*dw_dx(k, l, q) - & + q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx(k, l, q) + & + q_prim_vf(strxb + 4)%sf(k, l, q)*du_dy(k, l, q) + & + q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dy(k, l, q) - & + q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dy(k, l, q) + & + q_prim_vf(strxb + 5)%sf(k, l, q)*du_dz(k, l, q) + & + q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz(k, l, q) - & + q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz(k, l, q) + & + 2d0*G_K_field(k, l, q)*(1d0/2d0)*(du_dz(k, l, q) + & + dw_dx(k, l, q))) + + rhs_vf(strxb + 4)%sf(k, l, q) = rhs_vf(strxb + 4)%sf(k, l, q) + rho_K_field(k, l, q)* & + (q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dx(k, l, q) + & + q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dx(k, l, q) - & + q_prim_vf(strxb + 4)%sf(k, l, q)*du_dx(k, l, q) + & + q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy(k, l, q) + & + q_prim_vf(strxb + 2)%sf(k, l, q)*dw_dy(k, l, q) - & + q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy(k, l, q) + & + q_prim_vf(strxb + 5)%sf(k, l, q)*dv_dz(k, l, q) + & + q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz(k, l, q) - & + q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz(k, l, q) + & + 2d0*G_K_field(k, l, q)*(1d0/2d0)*(dv_dz(k, l, q) + & + dw_dy(k, l, q))) + + rhs_vf(strxe)%sf(k, l, q) = rhs_vf(strxe)%sf(k, l, q) + rho_K_field(k, l, q)* & + (q_prim_vf(strxe - 2)%sf(k, l, q)*dw_dx(k, l, q) + & + q_prim_vf(strxe - 2)%sf(k, l, q)*dw_dx(k, l, q) - & + q_prim_vf(strxe)%sf(k, l, q)*du_dx(k, l, q) + & + q_prim_vf(strxe - 1)%sf(k, l, q)*dw_dy(k, l, q) + & + q_prim_vf(strxe - 1)%sf(k, l, q)*dw_dy(k, l, q) - & + q_prim_vf(strxe)%sf(k, l, q)*dv_dy(k, l, q) + & + q_prim_vf(strxe)%sf(k, l, q)*dw_dz(k, l, q) + & + q_prim_vf(strxe)%sf(k, l, q)*dw_dz(k, l, q) - & + q_prim_vf(strxe)%sf(k, l, q)*dw_dz(k, l, q) + & + 2d0*G_K_field(k, l, q)*(dw_dz(k, l, q) - (1d0/3d0)* & + (du_dx(k, l, q) + & + dv_dy(k, l, q) + & + dw_dz(k, l, q)))) end do end do end do diff --git a/src/simulation/m_monopole.fpp b/src/simulation/m_monopole.fpp index ec550c8cc..f41e6bb28 100644 --- a/src/simulation/m_monopole.fpp +++ b/src/simulation/m_monopole.fpp @@ -31,7 +31,6 @@ module m_monopole real(kind(0d0)), allocatable, dimension(:) :: mag, length, npulse, dir, delay !$acc declare create(mag, length, npulse, dir, delay) - contains subroutine s_initialize_monopole_module() @@ -55,11 +54,10 @@ contains 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) + 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 @@ -84,182 +82,179 @@ contains 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)) :: the_time, 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 + !$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 - - the_time = t_step*dt - if ((the_time >= 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 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 + + the_time = t_step*dt + if ((the_time >= 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 - n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' + 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) + 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? + 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 + term_index = 2 - angle = 0.d0 - angle_z = 0.d0 + angle = 0.d0 + angle_z = 0.d0 - s2 = f_g(the_time, sound, const_sos, q, term_index)* & - f_delta(j, k, l, loc_mono(:, q), length(q), q, angle, angle_z) - !s2 = 1d0 + s2 = f_g(the_time, 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(the_time, sound, const_sos, q, term_index)* & - f_delta(j, k, l, loc_mono(:, q), length(q), q, angle, angle_z) - end if + if (support(q) == 5) then + term_index = 1 + s1 = f_g(the_time, 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/sound ! mono_mass_src(j, k, l) = mono_mass_src(j, k, l) + s2/const_sos - if (n == 0) then + 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(the_time,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 + ! 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 - ! 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 if (support(q) == 6) then - ! Cylindrical Coordinate - 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) - 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 + !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(the_time,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 - - if (model_eqns /= 4) then + else + ! 3D + if (dir(q) /= dflt_real) 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) + 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 if (support(q) == 6) then + ! Cylindrical Coordinate + 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) else - mono_E_src(j, k, l) = mono_E_src(j, k, l) + s2*sound/(n_tait - 1.d0) + 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 do + + 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) + !$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 @@ -267,7 +262,7 @@ contains !! @param sos Sound speed !! @param mysos Alternative speed of sound for testing function f_g(the_time, sos, mysos, nm, term_index) -!$acc routine seq + !$acc routine seq real(kind(0d0)), intent(IN) :: the_time, sos, mysos integer, intent(IN) :: nm real(kind(0d0)) :: period, t0, sigt, pa @@ -284,7 +279,7 @@ contains f_g = 0d0 if (term_index == 1) then f_g = mag(nm)*sin((the_time)*2.d0*pi/period)/mysos & - + mag(nm)/foc_length(nm)*(1.d0/(2.d0*pi/period)*cos((the_time)*2.d0*pi/period) & + + mag(nm)/foc_length(nm)*(1.d0/(2.d0*pi/period)*cos((the_time)*2.d0*pi/period) & - 1.d0/(2.d0*pi/period)) elseif (the_time <= (npulse(nm)*period + offset)) then f_g = mag(nm)*sin((the_time + offset)*2.d0*pi/period) @@ -294,7 +289,7 @@ contains sigt = length(nm)/sos/7.d0 t0 = 3.5d0*sigt f_g = mag(nm)/(dsqrt(2.d0*pi)*sigt)* & - dexp(-0.5d0*((the_time - t0)**2.d0)/(sigt**2.d0)) + dexp(-0.5d0*((the_time - t0)**2.d0)/(sigt**2.d0)) else if (pulse(nm) == 3) then ! Square wave sigt = length(nm)/sos @@ -314,8 +309,8 @@ contains !! @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 + !$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 @@ -347,7 +342,7 @@ contains 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) + dexp(-0.5d0*(hx/(sig/2.d0))**2.d0) else if (support(nm) == 0) then ! Support for all x f_delta = 1.d0 @@ -361,12 +356,12 @@ contains 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)) + 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) + dexp(-0.5d0*(hx/(sig/2.d0))**2.d0) else f_delta = 0d0 end if @@ -380,14 +375,14 @@ contains 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) + 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) + dexp(-0.5d0*(hx/sig)**2.d0) else if (support(nm) == 5) then ! Support along 'transducer' hx = x_cc(j) - mono_loc(1) @@ -396,7 +391,7 @@ contains 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) + dexp(-0.5d0*(hxnew/(sig/2.d0))**2.d0) angle = -atan(hy/(foc_length(nm) - hx)) else f_delta = 0d0 @@ -416,14 +411,14 @@ contains 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) + 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) + dexp(-0.5d0*(hz/sig)**2.d0) else if (support(nm) == 5) then ! Support along 'transducer' hx = x_cc(j) - mono_loc(1) @@ -435,7 +430,7 @@ contains (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) + dexp(-0.5d0*(hxnew/(sig/2.d0))**2.d0) angle = -atan(hy/(foc_length(nm) - hx)) angle_z = -atan(hz/(foc_length(nm) - hx)) diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index 5b7b89caf..c165401f4 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -43,7 +43,7 @@ module m_mpi_proxy integer, private :: err_code, ierr, v_size !> @} -!$acc declare create(q_cons_buff_send, q_cons_buff_recv, v_size) + !$acc declare create(q_cons_buff_send, q_cons_buff_recv, v_size) !real :: s_time, e_time !real :: compress_time, mpi_time, decompress_time @@ -62,9 +62,7 @@ contains ! for the sake of simplicity, both variables are provided sufficient ! storage to hold the largest buffer in the computational domain. - - - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then if (n > 0) then if (p > 0) then @:ALLOCATE(q_cons_buff_send(0:-1 + buff_size*(sys_size + 2*nb*4)* & @@ -99,7 +97,7 @@ contains @:ALLOCATE(q_cons_buff_send(0:-1 + buff_size*sys_size)) end if - @:ALLOCATE(q_cons_buff_recv(0:ubound(q_cons_buff_send, 1))) + @:ALLOCATE(q_cons_buff_recv(0:ubound(q_cons_buff_send, 1))) v_size = sys_size end if @@ -123,8 +121,8 @@ contains #:for VAR in ['t_step_old', 'm', 'n', 'p', 'm_glb', 'n_glb', 'p_glb', & & 't_step_start','t_step_stop','t_step_save','model_eqns', & - & 'num_fluids','time_stepper', 'riemann_solver', & - & 'wave_speeds', 'avg_state', 'precision', 'bc_x%beg', 'bc_x%end', & + & 'num_fluids','time_stepper', 'riemann_solver', & + & 'wave_speeds', 'avg_state', 'precision', 'bc_x%beg', 'bc_x%end', & & 'bc_y%beg', 'bc_y%end', 'bc_z%beg', 'bc_z%end', 'fd_order', & & 'num_probes', 'num_integrals', 'bubble_model', 'thermal', & & 'R0_type', 'num_mono', 'relax_model'] @@ -159,7 +157,7 @@ contains end do do j = 1, num_probes_max - do i = 1,3 + do i = 1, 3 call MPI_BCAST(mono(j)%loc(i), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) end do @@ -176,7 +174,7 @@ contains call MPI_BCAST(integral(j)%${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) #:endfor end do - + #endif end subroutine s_mpi_bcast_user_inputs ! ------------------------------- @@ -337,8 +335,8 @@ contains ! domain has been established. If not, the simulation exits. if (proc_rank == 0 .and. ierr == -1) then call s_mpi_abort('Unsupported combination of values '// & - 'of num_procs, m, n, p and '// & - 'weno_order. Exiting ...') + 'of num_procs, m, n, p and '// & + 'weno_order. Exiting ...') end if ! Creating new communicator using the Cartesian topology @@ -439,8 +437,8 @@ contains ! domain has been established. If not, the simulation exits. if (proc_rank == 0 .and. ierr == -1) then call s_mpi_abort('Unsupported combination of values '// & - 'of num_procs, m, n and '// & - 'weno_order. Exiting ...') + 'of num_procs, m, n and '// & + 'weno_order. Exiting ...') end if ! Creating new communicator using the Cartesian topology @@ -544,7 +542,6 @@ contains proc_coords(1) = proc_coords(1) - 1 end if - if (parallel_io) then if (proc_coords(1) < rem_cells) then start_idx(1) = (m + 1)*proc_coords(1) @@ -741,7 +738,6 @@ contains end subroutine s_mpi_sendrecv_grid_variables_buffers ! ----------------- - !> The goal of this procedure is to populate the buffers of !! the cell-average conservative variables by communicating !! with the neighboring processors. @@ -754,14 +750,14 @@ contains pbc_loc) type(scalar_field), dimension(sys_size), intent(INOUT) :: q_cons_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: pb, mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: pb, mv integer, intent(IN) :: mpi_dir integer, intent(IN) :: pbc_loc integer :: i, j, k, l, r, q !< Generic loop iterators - !$acc update device(v_size) +!$acc update device(v_size) #ifdef MFC_MPI @@ -775,7 +771,7 @@ contains if (bc_x%end >= 0) then ! PBC at the beginning and end ! Packing buffer to be sent to bc_x%end -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do l = 0, p do k = 0, n do j = m - buff_size + 1, m @@ -788,29 +784,29 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(4) gang vector default(present) private(r) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(4) gang vector default(present) private(r) do l = 0, p do k = 0, n do j = m - buff_size + 1, m - do i = sys_size + 1 , sys_size + 4 + do i = sys_size + 1, sys_size + 4 do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & + r = (i - 1) + (q - 1)*4 + v_size* & ((j - m - 1) + buff_size*((k + 1) + (n + 1)*l)) - q_cons_buff_send(r) = pb(j, k, l, i - sys_size , q) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) end do end do end do end do end do -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do l = 0, p do k = 0, n do j = m - buff_size + 1, m do i = sys_size + 1, sys_size + 4 do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & ((j - m - 1) + buff_size*((k + 1) + (n + 1)*l)) q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) end do @@ -824,58 +820,58 @@ contains #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - ! Send/receive buffer to/from bc_x%end/bc_x%beg - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + ! Send/receive buffer to/from bc_x%end/bc_x%beg + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 0, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - ! Send/receive buffer to/from bc_x%end/bc_x%beg - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & - q_cons_buff_recv(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + ! Send/receive buffer to/from bc_x%end/bc_x%beg + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 0, & + q_cons_buff_recv(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif !$acc update host(q_cons_buff_send) - if(qbmm .and. .not. polytropic) then - ! Send/receive buffer to/from bc_x%end/bc_x%beg - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + ! Send/receive buffer to/from bc_x%end/bc_x%beg + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 0, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - ! Send/receive buffer to/from bc_x%end/bc_x%beg - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & - q_cons_buff_recv(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + ! Send/receive buffer to/from bc_x%end/bc_x%beg + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 0, & + q_cons_buff_recv(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if #if defined(MFC_OpenACC) && defined(__PGI) @@ -885,7 +881,7 @@ contains else ! PBC at the beginning only ! Packing buffer to be sent to bc_x%beg -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do l = 0, p do k = 0, n do j = 0, buff_size - 1 @@ -898,38 +894,38 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do l = 0, p - do k = 0, n - do j = 0, buff_size - 1 - do i = sys_size + 1, sys_size + 4 - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - (j + buff_size*(k + (n + 1)*l)) - q_cons_buff_send(r) = pb(j, k, l, i-sys_size, q) - + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do l = 0, p + do k = 0, n + do j = 0, buff_size - 1 + do i = sys_size + 1, sys_size + 4 + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + (j + buff_size*(k + (n + 1)*l)) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do l = 0, p - do k = 0, n - do j = 0, buff_size - 1 - do i = sys_size + 1, sys_size + 4 - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - (j + buff_size*(k + (n + 1)*l)) - q_cons_buff_send(r) = mv(j, k, l, i-sys_size, q) - + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do l = 0, p + do k = 0, n + do j = 0, buff_size - 1 + do i = sys_size + 1, sys_size + 4 + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + (j + buff_size*(k + (n + 1)*l)) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + + end do end do end do end do end do - end do end if @@ -937,54 +933,54 @@ contains #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) - - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - ! Send/receive buffer to/from bc_x%end/bc_x%beg - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & - q_cons_buff_recv(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + ! Send/receive buffer to/from bc_x%end/bc_x%beg + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + q_cons_buff_recv(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif -!$acc update host(q_cons_buff_send) + !$acc update host(q_cons_buff_send) - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - ! Send/receive buffer to/from bc_x%end/bc_x%beg - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & - q_cons_buff_recv(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + ! Send/receive buffer to/from bc_x%end/bc_x%beg + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + q_cons_buff_recv(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if #if defined(MFC_OpenACC) && defined(__PGI) @@ -1000,18 +996,18 @@ contains #endif ! Unpacking buffer received from bc_x%beg -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do l = 0, p do k = 0, n do j = -buff_size, -1 do i = 1, sys_size r = (i - 1) + v_size* & (j + buff_size*((k + 1) + (n + 1)*l)) - q_cons_vf(i)%sf(j, k, l) = q_cons_buff_recv(r) -#if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then - print *, "Error", j, k, l, i - error stop "NaN(s) in recv" + q_cons_vf(i)%sf(j, k, l) = q_cons_buff_recv(r) +#if defined(__INTEL_COMPILER) + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then + print *, "Error", j, k, l, i + error stop "NaN(s) in recv" end if #endif end do @@ -1019,38 +1015,38 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do l = 0, p - do k = 0, n - do j = -buff_size, -1 - do i = sys_size + 1, sys_size + 4 - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - (j + buff_size*((k + 1) + (n + 1)*l)) - pb(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) - + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do l = 0, p + do k = 0, n + do j = -buff_size, -1 + do i = sys_size + 1, sys_size + 4 + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + (j + buff_size*((k + 1) + (n + 1)*l)) + pb(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do l = 0, p - do k = 0, n - do j = -buff_size, -1 - do i = sys_size + 1, sys_size + 4 - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - (j + buff_size*((k + 1) + (n + 1)*l)) - mv(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) - + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do l = 0, p + do k = 0, n + do j = -buff_size, -1 + do i = sys_size + 1, sys_size + 4 + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + (j + buff_size*((k + 1) + (n + 1)*l)) + mv(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + + end do end do end do end do end do - end do end if @@ -1058,7 +1054,7 @@ contains if (bc_x%beg >= 0) then ! PBC at the end and beginning -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) ! Packing buffer to be sent to bc_x%beg do l = 0, p do k = 0, n @@ -1072,92 +1068,92 @@ contains end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - ! Packing buffer to be sent to bc_x%beg - do l = 0, p - do k = 0, n - do j = 0, buff_size - 1 - do i = sys_size + 1, sys_size + 4 - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - (j + buff_size*(k + (n + 1)*l)) - q_cons_buff_send(r) = pb(j, k, l, i-sys_size, q) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + ! Packing buffer to be sent to bc_x%beg + do l = 0, p + do k = 0, n + do j = 0, buff_size - 1 + do i = sys_size + 1, sys_size + 4 + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + (j + buff_size*(k + (n + 1)*l)) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - ! Packing buffer to be sent to bc_x%beg - do l = 0, p - do k = 0, n - do j = 0, buff_size - 1 - do i = sys_size + 1, sys_size + 4 - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - (j + buff_size*(k + (n + 1)*l)) - q_cons_buff_send(r) = mv(j, k, l, i-sys_size, q) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + ! Packing buffer to be sent to bc_x%beg + do l = 0, p + do k = 0, n + do j = 0, buff_size - 1 + do i = sys_size + 1, sys_size + 4 + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + (j + buff_size*(k + (n + 1)*l)) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do end if !call MPI_Barrier(MPI_COMM_WORLD, ierr) #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size+2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & - q_cons_buff_recv(0), & - buff_size*(sys_size+2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & - q_cons_buff_recv(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + q_cons_buff_recv(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif - + !$acc update host(q_cons_buff_send) - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size+2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & - q_cons_buff_recv(0), & - buff_size*(sys_size+2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & - q_cons_buff_recv(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + q_cons_buff_recv(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if #if defined(MFC_OpenACC) && defined(__PGI) @@ -1167,7 +1163,7 @@ contains else ! PBC at the end only ! Packing buffer to be sent to bc_x%end -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do l = 0, p do k = 0, n do j = m - buff_size + 1, m @@ -1180,38 +1176,38 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do l = 0, p - do k = 0, n - do j = m - buff_size + 1, m - do i = sys_size + 1, sys_size + 4 - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j - m - 1) + buff_size*((k + 1) + (n + 1)*l)) - q_cons_buff_send(r) = pb(j, k, l, i-sys_size, q) - + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do l = 0, p + do k = 0, n + do j = m - buff_size + 1, m + do i = sys_size + 1, sys_size + 4 + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j - m - 1) + buff_size*((k + 1) + (n + 1)*l)) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do l = 0, p - do k = 0, n - do j = m - buff_size + 1, m - do i = sys_size + 1, sys_size + 4 - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j - m - 1) + buff_size*((k + 1) + (n + 1)*l)) - q_cons_buff_send(r) = mv(j, k, l, i-sys_size, q) - + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do l = 0, p + do k = 0, n + do j = m - buff_size + 1, m + do i = sys_size + 1, sys_size + 4 + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j - m - 1) + buff_size*((k + 1) + (n + 1)*l)) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + + end do end do end do end do end do - end do end if @@ -1219,54 +1215,54 @@ contains #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & - q_cons_buff_recv(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 0, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + else + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 0, & + q_cons_buff_recv(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif - + !$acc update host(q_cons_buff_send) - - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & - q_cons_buff_recv(0), & - buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 0, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + else + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 0, & + q_cons_buff_recv(0), & + buff_size*sys_size*(n + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_x%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if #if defined(MFC_OpenACC) && defined(__PGI) @@ -1280,18 +1276,18 @@ contains end if ! Unpacking buffer received from bc_x%end -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do l = 0, p do k = 0, n do j = m + 1, m + buff_size do i = 1, sys_size r = (i - 1) + v_size* & ((j - m - 1) + buff_size*(k + (n + 1)*l)) - q_cons_vf(i)%sf(j, k, l) = q_cons_buff_recv(r) -#if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then - print *, "Error", j, k, l, i - error stop "NaN(s) in recv" + q_cons_vf(i)%sf(j, k, l) = q_cons_buff_recv(r) +#if defined(__INTEL_COMPILER) + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then + print *, "Error", j, k, l, i + error stop "NaN(s) in recv" end if #endif end do @@ -1299,38 +1295,38 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do l = 0, p - do k = 0, n - do j = m + 1, m + buff_size - do i = sys_size + 1, sys_size + 4 - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j - m - 1) + buff_size*(k + (n + 1)*l)) - pb(j, k, l, i-sys_size, q) = q_cons_buff_recv(r) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do l = 0, p + do k = 0, n + do j = m + 1, m + buff_size + do i = sys_size + 1, sys_size + 4 + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j - m - 1) + buff_size*(k + (n + 1)*l)) + pb(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do l = 0, p - do k = 0, n - do j = m + 1, m + buff_size - do i = sys_size + 1, sys_size + 4 - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j - m - 1) + buff_size*(k + (n + 1)*l)) - mv(j, k, l, i-sys_size, q) = q_cons_buff_recv(r) - + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do l = 0, p + do k = 0, n + do j = m + 1, m + buff_size + do i = sys_size + 1, sys_size + 4 + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j - m - 1) + buff_size*(k + (n + 1)*l)) + mv(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + + end do end do end do end do end do - end do end if @@ -1345,7 +1341,7 @@ contains if (bc_y%end >= 0) then ! PBC at the beginning and end ! Packing buffer to be sent to bc_y%end -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = 0, p do k = n - buff_size + 1, n @@ -1359,92 +1355,92 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = n - buff_size + 1, n - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k - n + buff_size - 1) + buff_size*l)) - q_cons_buff_send(r) = pb(j, k, l, i-sys_size, q) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = n - buff_size + 1, n + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k - n + buff_size - 1) + buff_size*l)) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = n - buff_size + 1, n - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k - n + buff_size - 1) + buff_size*l)) - q_cons_buff_send(r) = mv(j, k, l, i-sys_size, q) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = n - buff_size + 1, n + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k - n + buff_size - 1) + buff_size*l)) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do end if !call MPI_Barrier(MPI_COMM_WORLD, ierr) #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size+2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & - q_cons_buff_recv(0), & - buff_size*(sys_size+2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 0, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & - q_cons_buff_recv(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 0, & + q_cons_buff_recv(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif !$acc update host(q_cons_buff_send) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size+2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & - q_cons_buff_recv(0), & - buff_size*(sys_size+2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 0, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & - q_cons_buff_recv(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 0, & + q_cons_buff_recv(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if #if defined(MFC_OpenACC) && defined(__PGI) @@ -1454,7 +1450,7 @@ contains else ! PBC at the beginning only ! Packing buffer to be sent to bc_y%beg -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = 0, p do k = 0, buff_size - 1 @@ -1468,92 +1464,92 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = 0, buff_size - 1 - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q - 1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - (k + buff_size*l)) - q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = 0, buff_size - 1 + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + (k + buff_size*l)) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = 0, buff_size - 1 - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - (k + buff_size*l)) - q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) - end do + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = 0, buff_size - 1 + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + (k + buff_size*l)) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + end do + end do end do end do end do - end do end if !call MPI_Barrier(MPI_COMM_WORLD, ierr) #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & - q_cons_buff_recv(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + q_cons_buff_recv(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif !$acc update host(q_cons_buff_send) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & - q_cons_buff_recv(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + q_cons_buff_recv(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if #if defined(MFC_OpenACC) && defined(__PGI) @@ -1569,7 +1565,7 @@ contains #endif ! Unpacking buffer received from bc_y%beg -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = 0, p do k = -buff_size, -1 @@ -1578,48 +1574,48 @@ contains ((j + buff_size) + (m + 2*buff_size + 1)* & ((k + buff_size) + buff_size*l)) q_cons_vf(i)%sf(j, k, l) = q_cons_buff_recv(r) -#if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then - print *, "Error", j, k, l, i - error stop "NaN(s) in recv" +#if defined(__INTEL_COMPILER) + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then + print *, "Error", j, k, l, i + error stop "NaN(s) in recv" end if -#endif +#endif end do end do end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = -buff_size, -1 - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + buff_size*l)) - pb(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = -buff_size, -1 + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + buff_size*l)) + pb(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = -buff_size, -1 - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + buff_size*l)) - mv(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = -buff_size, -1 + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + buff_size*l)) + mv(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + end do end do end do end do end do - end do end if else ! PBC at the end @@ -1627,7 +1623,7 @@ contains if (bc_y%beg >= 0) then ! PBC at the end and beginning ! Packing buffer to be sent to bc_y%beg -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = 0, p do k = 0, buff_size - 1 @@ -1641,93 +1637,93 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = 0, buff_size - 1 - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - (k + buff_size*l)) - q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = 0, buff_size - 1 + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + (k + buff_size*l)) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = 0, buff_size - 1 - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - (k + buff_size*l)) - q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = 0, buff_size - 1 + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + (k + buff_size*l)) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do end if !call MPI_Barrier(MPI_COMM_WORLD, ierr) #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & - q_cons_buff_recv(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + q_cons_buff_recv(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif !$acc update host(q_cons_buff_send) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & - q_cons_buff_recv(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + q_cons_buff_recv(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if #if defined(MFC_OpenACC) && defined(__PGI) @@ -1737,7 +1733,7 @@ contains else ! PBC at the end only ! Packing buffer to be sent to bc_y%end -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = 0, p do k = n - buff_size + 1, n @@ -1751,92 +1747,92 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = n - buff_size + 1, n - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k - n + buff_size - 1) + buff_size*l)) - q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = n - buff_size + 1, n + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k - n + buff_size - 1) + buff_size*l)) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = n - buff_size + 1, n - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k - n + buff_size - 1) + buff_size*l)) - q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = n - buff_size + 1, n + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k - n + buff_size - 1) + buff_size*l)) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do end if !call MPI_Barrier(MPI_COMM_WORLD, ierr) #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & - q_cons_buff_recv(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 0, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + else + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 0, & + q_cons_buff_recv(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif !$acc update host(q_cons_buff_send) ! Send/receive buffer to/from bc_x%end/bc_x%beg - if(qbmm .and. .not. polytropic) then - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & - q_cons_buff_recv(0), & - buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - else - call MPI_SENDRECV( & - q_cons_buff_send(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & - q_cons_buff_recv(0), & - buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + if (qbmm .and. .not. polytropic) then + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 0, & + q_cons_buff_recv(0), & + buff_size*(sys_size + 2*nb*4)*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + else + call MPI_SENDRECV( & + q_cons_buff_send(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 0, & + q_cons_buff_recv(0), & + buff_size*sys_size*(m + 2*buff_size + 1)*(p + 1), & + MPI_DOUBLE_PRECISION, bc_y%end, 1, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if #if defined(MFC_OpenACC) && defined(__PGI) @@ -1852,7 +1848,7 @@ contains #endif ! Unpacking buffer received form bc_y%end -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = 0, p do k = n + 1, n + buff_size @@ -1861,49 +1857,49 @@ contains ((j + buff_size) + (m + 2*buff_size + 1)* & ((k - n - 1) + buff_size*l)) q_cons_vf(i)%sf(j, k, l) = q_cons_buff_recv(r) -#if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then +#if defined(__INTEL_COMPILER) + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then print *, "Error", j, k, l, i error stop "NaN(s) in recv" end if -#endif +#endif end do end do end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = n + 1, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k - n - 1) + buff_size*l)) - pb(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = n + 1, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k - n - 1) + buff_size*l)) + pb(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, p - do k = n + 1, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k - n - 1) + buff_size*l)) - mv(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, p + do k = n + 1, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k - n - 1) + buff_size*l)) + mv(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + end do end do end do end do end do - end do end if end if @@ -1917,7 +1913,7 @@ contains if (bc_z%end >= 0) then ! PBC at the beginning and end ! Packing buffer to be sent to bc_z%end -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = p - buff_size + 1, p do k = -buff_size, n + buff_size @@ -1932,46 +1928,46 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = p - buff_size + 1, p - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l - p + buff_size - 1))) - q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = p - buff_size + 1, p + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)* & + (l - p + buff_size - 1))) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = p - buff_size + 1, p - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l - p + buff_size - 1))) - q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = p - buff_size + 1, p + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)* & + (l - p + buff_size - 1))) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do end if !call MPI_Barrier(MPI_COMM_WORLD, ierr) #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV( & @@ -1983,13 +1979,13 @@ contains MPI_DOUBLE_PRECISION, bc_z%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif - + !$acc update host(q_cons_buff_send) - + ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV( & q_cons_buff_send(0), & @@ -2007,7 +2003,7 @@ contains else ! PBC at the beginning only ! Packing buffer to be sent to bc_z%beg -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = 0, buff_size - 1 do k = -buff_size, n + buff_size @@ -2021,38 +2017,38 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, buff_size - 1 - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)*l)) - q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, buff_size - 1 + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)*l)) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, buff_size - 1 - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)*l)) - q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, buff_size - 1 + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)*l)) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do end if @@ -2060,7 +2056,7 @@ contains #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV( & @@ -2072,13 +2068,13 @@ contains MPI_DOUBLE_PRECISION, bc_z%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif - + !$acc update host(q_cons_buff_send) - + ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV( & q_cons_buff_send(0), & @@ -2102,7 +2098,7 @@ contains #endif ! Unpacking buffer from bc_z%beg -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = -buff_size, -1 do k = -buff_size, n + buff_size @@ -2112,51 +2108,51 @@ contains ((k + buff_size) + (n + 2*buff_size + 1)* & (l + buff_size))) q_cons_vf(i)%sf(j, k, l) = q_cons_buff_recv(r) -#if defined(__INTEL_COMPILER) - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then +#if defined(__INTEL_COMPILER) + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then print *, "Error", j, k, l, i error stop "NaN(s) in recv" end if -#endif +#endif end do end do end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = -buff_size, -1 - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l + buff_size))) - pb(j, k, l, i-sys_size, q) = q_cons_buff_recv(r) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = -buff_size, -1 + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)* & + (l + buff_size))) + pb(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = -buff_size, -1 - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l + buff_size))) - mv(j, k, l, i-sys_size, q) = q_cons_buff_recv(r) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = -buff_size, -1 + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)* & + (l + buff_size))) + mv(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + end do end do end do end do end do - end do end if else ! PBC at the end @@ -2164,7 +2160,7 @@ contains if (bc_z%beg >= 0) then ! PBC at the end and beginning ! Packing buffer to be sent to bc_z%beg -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = 0, buff_size - 1 do k = -buff_size, n + buff_size @@ -2178,45 +2174,45 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, buff_size - 1 - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)*l)) - q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, buff_size - 1 + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)*l)) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = 0, buff_size - 1 - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)*l)) - q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = 0, buff_size - 1 + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)*l)) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do end if !call MPI_Barrier(MPI_COMM_WORLD, ierr) #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV( & @@ -2228,8 +2224,8 @@ contains MPI_DOUBLE_PRECISION, bc_z%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif !$acc update host(q_cons_buff_send) @@ -2243,7 +2239,7 @@ contains buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1), & MPI_DOUBLE_PRECISION, bc_z%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - + #if defined(MFC_OpenACC) && defined(__PGI) end if #endif @@ -2251,7 +2247,7 @@ contains else ! PBC at the end only ! Packing buffer to be sent to bc_z%end -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = p - buff_size + 1, p do k = -buff_size, n + buff_size @@ -2266,39 +2262,39 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = p - buff_size + 1, p - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l - p + buff_size - 1))) - q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = p - buff_size + 1, p + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)* & + (l - p + buff_size - 1))) + q_cons_buff_send(r) = pb(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = p - buff_size + 1, p - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l - p + buff_size - 1))) - q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = p - buff_size + 1, p + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)* & + (l - p + buff_size - 1))) + q_cons_buff_send(r) = mv(j, k, l, i - sys_size, q) + end do end do end do end do end do - end do end if @@ -2306,7 +2302,7 @@ contains #if defined(MFC_OpenACC) && defined(__PGI) if (cu_mpi) then -!$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) + !$acc host_data use_device( q_cons_buff_recv, q_cons_buff_send ) ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV( & @@ -2318,11 +2314,11 @@ contains MPI_DOUBLE_PRECISION, bc_z%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) -!$acc end host_data -!$acc wait + !$acc end host_data + !$acc wait else #endif -!$acc update host(q_cons_buff_send) + !$acc update host(q_cons_buff_send) ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV( & @@ -2347,7 +2343,7 @@ contains #endif ! Unpacking buffer received from bc_z%end -!$acc parallel loop collapse(4) gang vector default(present) private(r) + !$acc parallel loop collapse(4) gang vector default(present) private(r) do i = 1, sys_size do l = p + 1, p + buff_size do k = -buff_size, n + buff_size @@ -2357,9 +2353,9 @@ contains ((k + buff_size) + (n + 2*buff_size + 1)* & (l - p - 1))) q_cons_vf(i)%sf(j, k, l) = q_cons_buff_recv(r) -#if defined(__INTEL_COMPILER) - - if(ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then +#if defined(__INTEL_COMPILER) + + if (ieee_is_nan(q_cons_vf(i)%sf(j, k, l))) then print *, "Error", j, k, l, i error stop "NaN(s) in recv" end if @@ -2369,39 +2365,39 @@ contains end do end do - if(qbmm .and. .not. polytropic) then -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = p + 1, p + buff_size - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l - p - 1))) - pb(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + if (qbmm .and. .not. polytropic) then + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = p + 1, p + buff_size + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)* & + (l - p - 1))) + pb(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + end do end do end do end do end do - end do -!$acc parallel loop collapse(5) gang vector default(present) private(r) - do i = sys_size + 1, sys_size + 4 - do l = p + 1, p + buff_size - do k = -buff_size, n + buff_size - do j = -buff_size, m + buff_size - do q = 1, nb - r = (i - 1) + (q-1)*4 + nb*4 + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l - p - 1))) - mv(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + !$acc parallel loop collapse(5) gang vector default(present) private(r) + do i = sys_size + 1, sys_size + 4 + do l = p + 1, p + buff_size + do k = -buff_size, n + buff_size + do j = -buff_size, m + buff_size + do q = 1, nb + r = (i - 1) + (q - 1)*4 + nb*4 + v_size* & + ((j + buff_size) + (m + 2*buff_size + 1)* & + ((k + buff_size) + (n + 2*buff_size + 1)* & + (l - p - 1))) + mv(j, k, l, i - sys_size, q) = q_cons_buff_recv(r) + end do end do end do end do end do - end do end if end if @@ -2425,5 +2421,4 @@ contains end subroutine s_finalize_mpi_proxy_module ! --------------------------- - end module m_mpi_proxy diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index 8a64e685c..a1291621e 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -36,12 +36,11 @@ module m_qbmm type(int_bounds_info) :: is1, is2, is3 - integer, allocatable, dimension(:) :: bubrs + integer, allocatable, dimension(:) :: bubrs integer, allocatable, dimension(:, :) :: bubmoms - -!$acc declare create(momrhs, nterms, is1, is2, is3) -!$acc declare create(bubrs, bubmoms) + !$acc declare create(momrhs, nterms, is1, is2, is3) + !$acc declare create(bubrs, bubmoms) contains @@ -68,8 +67,8 @@ contains ! Assigns the required RHS moments for moment transport equations ! The rhs%(:,3) is only to be used for R0 quadrature, not for computing X/Y indices - ! Accounts for different governing equations in polytropic and non-polytropic models - if(.not. polytropic) then + ! Accounts for different governing equations in polytropic and non-polytropic models + if (.not. polytropic) then do q = 1, nb do i1 = 0, 2; do i2 = 0, 2 if ((i1 + i2) <= 2) then @@ -82,7 +81,7 @@ contains momrhs(2, i1, i2, 2, q) = 1.d0 + i2 momrhs(3, i1, i2, 2, q) = 0d0 - momrhs(1, i1, i2, 3, q) = -1.d0 + i1 + momrhs(1, i1, i2, 3, q) = -1.d0 + i1 momrhs(2, i1, i2, 3, q) = -1.d0 + i2 momrhs(3, i1, i2, 3, q) = 0d0 @@ -104,7 +103,7 @@ contains momrhs(3, i1, i2, 6, q) = 0d0 end if - momrhs(1, i1, i2, 7, q) = -1.d0 + i1 + momrhs(1, i1, i2, 7, q) = -1.d0 + i1 momrhs(2, i1, i2, 7, q) = -1.d0 + i2 momrhs(3, i1, i2, 7, q) = 0d0 @@ -134,15 +133,15 @@ contains momrhs(2, i1, i2, 6, q) = 1d0 + i2 momrhs(3, i1, i2, 6, q) = 0d0 - momrhs(1, i1, i2, 7, q) = -1d0 + i1 + momrhs(1, i1, i2, 7, q) = -1d0 + i1 momrhs(2, i1, i2, 7, q) = -1d0 + i2 momrhs(3, i1, i2, 7, q) = 0d0 - momrhs(1, i1, i2, 8, q) = -1d0 + i1 + momrhs(1, i1, i2, 8, q) = -1d0 + i1 momrhs(2, i1, i2, 8, q) = i2 momrhs(3, i1, i2, 8, q) = 0d0 - momrhs(1, i1, i2, 9, q) = -1d0 + i1 + momrhs(1, i1, i2, 9, q) = -1d0 + i1 momrhs(2, i1, i2, 9, q) = 1d0 + i2 momrhs(3, i1, i2, 9, q) = 0d0 @@ -150,7 +149,7 @@ contains momrhs(2, i1, i2, 10, q) = i2 momrhs(3, i1, i2, 10, q) = 0d0 - momrhs(1, i1, i2, 11, q) = -1d0 + i1 + momrhs(1, i1, i2, 11, q) = -1d0 + i1 momrhs(2, i1, i2, 11, q) = 1d0 + i2 momrhs(3, i1, i2, 11, q) = 0d0 @@ -158,89 +157,89 @@ contains momrhs(2, i1, i2, 12, q) = 1d0 + i2 momrhs(3, i1, i2, 12, q) = 0d0 - momrhs(1, i1, i2, 13, q) = -1d0 + i1 + momrhs(1, i1, i2, 13, q) = -1d0 + i1 momrhs(2, i1, i2, 13, q) = -1d0 + i2 momrhs(3, i1, i2, 13, q) = 0d0 - momrhs(1, i1, i2, 14, q) = -1d0 + i1 + momrhs(1, i1, i2, 14, q) = -1d0 + i1 momrhs(2, i1, i2, 14, q) = i2 momrhs(3, i1, i2, 14, q) = 0d0 - momrhs(1, i1, i2, 15, q) = -1d0 + i1 + momrhs(1, i1, i2, 15, q) = -1d0 + i1 momrhs(2, i1, i2, 15, q) = 1d0 + i2 - momrhs(3, i1, i2, 15, q) = 0d0 + momrhs(3, i1, i2, 15, q) = 0d0 - momrhs(1, i1, i2, 16, q) = -2d0 + i1 - momrhs(2, i1, i2, 16, q) = i2 - momrhs(3, i1, i2, 16, q) = 0d0 + momrhs(1, i1, i2, 16, q) = -2d0 + i1 + momrhs(2, i1, i2, 16, q) = i2 + momrhs(3, i1, i2, 16, q) = 0d0 - momrhs(1, i1, i2, 17, q) = -2d0 + i1 - momrhs(2, i1, i2, 17, q) = -1d0 + i2 - momrhs(3, i1, i2, 17, q) = 0d0 + momrhs(1, i1, i2, 17, q) = -2d0 + i1 + momrhs(2, i1, i2, 17, q) = -1d0 + i2 + momrhs(3, i1, i2, 17, q) = 0d0 - momrhs(1, i1, i2, 18, q) = -2d0 + i1 - momrhs(2, i1, i2, 18, q) = 1d0 + i2 - momrhs(3, i1, i2, 18, q) = 0d0 + momrhs(1, i1, i2, 18, q) = -2d0 + i1 + momrhs(2, i1, i2, 18, q) = 1d0 + i2 + momrhs(3, i1, i2, 18, q) = 0d0 - momrhs(1, i1, i2, 19, q) = -2d0 + i1 - momrhs(2, i1, i2, 19, q) = 2d0 + i2 - momrhs(3, i1, i2, 19, q) = 0d0 + momrhs(1, i1, i2, 19, q) = -2d0 + i1 + momrhs(2, i1, i2, 19, q) = 2d0 + i2 + momrhs(3, i1, i2, 19, q) = 0d0 - momrhs(1, i1, i2, 20, q) = -2d0 + i1 - momrhs(2, i1, i2, 20, q) = -1d0 + i2 + momrhs(1, i1, i2, 20, q) = -2d0 + i1 + momrhs(2, i1, i2, 20, q) = -1d0 + i2 momrhs(3, i1, i2, 20, q) = 0d0 - momrhs(1, i1, i2, 21, q) = -2d0 + i1 - momrhs(2, i1, i2, 21, q) = i2 + momrhs(1, i1, i2, 21, q) = -2d0 + i1 + momrhs(2, i1, i2, 21, q) = i2 momrhs(3, i1, i2, 21, q) = 0d0 - momrhs(1, i1, i2, 22, q) = -2d0 + i1 - momrhs(2, i1, i2, 22, q) = -1d0 + i2 + momrhs(1, i1, i2, 22, q) = -2d0 + i1 + momrhs(2, i1, i2, 22, q) = -1d0 + i2 momrhs(3, i1, i2, 22, q) = 0d0 - momrhs(1, i1, i2, 23, q) = -2d0 + i1 - momrhs(2, i1, i2, 23, q) = i2 + momrhs(1, i1, i2, 23, q) = -2d0 + i1 + momrhs(2, i1, i2, 23, q) = i2 momrhs(3, i1, i2, 23, q) = 0d0 - momrhs(1, i1, i2, 24, q) = -3d0 + i1 - momrhs(2, i1, i2, 24, q) = i2 + momrhs(1, i1, i2, 24, q) = -3d0 + i1 + momrhs(2, i1, i2, 24, q) = i2 momrhs(3, i1, i2, 24, q) = 0d0 - momrhs(1, i1, i2, 25, q) = -3d0 + i1 + momrhs(1, i1, i2, 25, q) = -3d0 + i1 momrhs(2, i1, i2, 25, q) = -1d0 + i2 momrhs(3, i1, i2, 25, q) = 0d0 - momrhs(1, i1, i2, 26, q) = -2d0 + i1 - momrhs(2, i1, i2, 26, q) = i2 - momrhs(3, i1, i2, 26, q) = 0d0 + momrhs(1, i1, i2, 26, q) = -2d0 + i1 + momrhs(2, i1, i2, 26, q) = i2 + momrhs(3, i1, i2, 26, q) = 0d0 - momrhs(1, i1, i2, 27, q) = -1d0 + i1 + momrhs(1, i1, i2, 27, q) = -1d0 + i1 momrhs(2, i1, i2, 27, q) = -1d0 + i2 - momrhs(3, i1, i2, 27, q) = 0d0 + momrhs(3, i1, i2, 27, q) = 0d0 - momrhs(1, i1, i2, 28, q) = -1d0 + i1 - momrhs(2, i1, i2, 28, q) = i2 - momrhs(3, i1, i2, 28, q) = 0d0 + momrhs(1, i1, i2, 28, q) = -1d0 + i1 + momrhs(2, i1, i2, 28, q) = i2 + momrhs(3, i1, i2, 28, q) = 0d0 - momrhs(1, i1, i2, 29, q) = -2d0 + i1 - momrhs(2, i1, i2, 29, q) = i2 - momrhs(3, i1, i2, 29, q) = 0d0 + momrhs(1, i1, i2, 29, q) = -2d0 + i1 + momrhs(2, i1, i2, 29, q) = i2 + momrhs(3, i1, i2, 29, q) = 0d0 - momrhs(1, i1, i2, 30, q) = -1d0 + i1 + momrhs(1, i1, i2, 30, q) = -1d0 + i1 momrhs(2, i1, i2, 30, q) = -1d0 + i2 - momrhs(3, i1, i2, 30, q) = 0d0 + momrhs(3, i1, i2, 30, q) = 0d0 - momrhs(1, i1, i2, 31, q) = -1d0 + i1 - momrhs(2, i1, i2, 31, q) = i2 - momrhs(3, i1, i2, 31, q) = 0d0 + momrhs(1, i1, i2, 31, q) = -1d0 + i1 + momrhs(2, i1, i2, 31, q) = i2 + momrhs(3, i1, i2, 31, q) = 0d0 - momrhs(1, i1, i2, 32, q) = -2d0 + i1 - momrhs(2, i1, i2, 32, q) = i2 - momrhs(3, i1, i2, 32, q) = 0d0 + momrhs(1, i1, i2, 32, q) = -2d0 + i1 + momrhs(2, i1, i2, 32, q) = i2 + momrhs(3, i1, i2, 32, q) = 0d0 end if end if end do; end do - end do + end do else do q = 1, nb @@ -277,7 +276,7 @@ contains momrhs(3, i1, i2, 6, q) = 0d0 end if - momrhs(1, i1, i2, 7, q) = -1.d0 + i1 + momrhs(1, i1, i2, 7, q) = -1.d0 + i1 momrhs(2, i1, i2, 7, q) = -1.d0 + i2 momrhs(3, i1, i2, 7, q) = 0d0 @@ -331,63 +330,62 @@ contains momrhs(2, i1, i2, 12, q) = 1d0 + i2 momrhs(3, i1, i2, 12, q) = 0d0 - momrhs(1, i1, i2, 13, q) = -1d0 + i1 + momrhs(1, i1, i2, 13, q) = -1d0 + i1 momrhs(2, i1, i2, 13, q) = -1d0 + i2 momrhs(3, i1, i2, 13, q) = 0d0 - momrhs(1, i1, i2, 14, q) = -1d0 + i1 + momrhs(1, i1, i2, 14, q) = -1d0 + i1 momrhs(2, i1, i2, 14, q) = i2 momrhs(3, i1, i2, 14, q) = 0d0 - momrhs(1, i1, i2, 15, q) = -1d0 + i1 + momrhs(1, i1, i2, 15, q) = -1d0 + i1 momrhs(2, i1, i2, 15, q) = 1d0 + i2 momrhs(3, i1, i2, 15, q) = 0d0 - momrhs(1, i1, i2, 16, q) = -2d0 + i1 - momrhs(2, i1, i2, 16, q) = i2 - momrhs(3, i1, i2, 16, q) = 0d0 + momrhs(1, i1, i2, 16, q) = -2d0 + i1 + momrhs(2, i1, i2, 16, q) = i2 + momrhs(3, i1, i2, 16, q) = 0d0 - momrhs(1, i1, i2, 17, q) = -2d0 + i1 - momrhs(2, i1, i2, 17, q) = -1d0 + i2 - momrhs(3, i1, i2, 17, q) = 0d0 + momrhs(1, i1, i2, 17, q) = -2d0 + i1 + momrhs(2, i1, i2, 17, q) = -1d0 + i2 + momrhs(3, i1, i2, 17, q) = 0d0 - momrhs(1, i1, i2, 18, q) = -2d0 + i1 - momrhs(2, i1, i2, 18, q) = 1d0 + i2 - momrhs(3, i1, i2, 18, q) = 0d0 + momrhs(1, i1, i2, 18, q) = -2d0 + i1 + momrhs(2, i1, i2, 18, q) = 1d0 + i2 + momrhs(3, i1, i2, 18, q) = 0d0 - momrhs(1, i1, i2, 19, q) = -2d0 + i1 - momrhs(2, i1, i2, 19, q) = 2d0 + i2 - momrhs(3, i1, i2, 19, q) = 0d0 + momrhs(1, i1, i2, 19, q) = -2d0 + i1 + momrhs(2, i1, i2, 19, q) = 2d0 + i2 + momrhs(3, i1, i2, 19, q) = 0d0 - momrhs(1, i1, i2, 20, q) = -2d0 + i1 - momrhs(2, i1, i2, 20, q) = -1d0 + i2 + momrhs(1, i1, i2, 20, q) = -2d0 + i1 + momrhs(2, i1, i2, 20, q) = -1d0 + i2 momrhs(3, i1, i2, 20, q) = 0d0 - momrhs(1, i1, i2, 21, q) = -2d0 + i1 - momrhs(2, i1, i2, 21, q) = i2 + momrhs(1, i1, i2, 21, q) = -2d0 + i1 + momrhs(2, i1, i2, 21, q) = i2 momrhs(3, i1, i2, 21, q) = 0d0 - momrhs(1, i1, i2, 22, q) = -2d0 + i1 -3d0*gam - momrhs(2, i1, i2, 22, q) = -1d0 + i2 + momrhs(1, i1, i2, 22, q) = -2d0 + i1 - 3d0*gam + momrhs(2, i1, i2, 22, q) = -1d0 + i2 momrhs(3, i1, i2, 22, q) = 3d0*gam - momrhs(1, i1, i2, 23, q) = -2d0 + i1 -3d0*gam - momrhs(2, i1, i2, 23, q) = i2 + momrhs(1, i1, i2, 23, q) = -2d0 + i1 - 3d0*gam + momrhs(2, i1, i2, 23, q) = i2 momrhs(3, i1, i2, 23, q) = 3d0*gam - momrhs(1, i1, i2, 24, q) = -3d0 + i1 - momrhs(2, i1, i2, 24, q) = i2 + momrhs(1, i1, i2, 24, q) = -3d0 + i1 + momrhs(2, i1, i2, 24, q) = i2 momrhs(3, i1, i2, 24, q) = 0d0 - momrhs(1, i1, i2, 25, q) = -3d0 + i1 + momrhs(1, i1, i2, 25, q) = -3d0 + i1 momrhs(2, i1, i2, 25, q) = -1d0 + i2 momrhs(3, i1, i2, 25, q) = 0d0 - momrhs(1, i1, i2, 26, q) = -2d0 + i1 -3d0*gam - momrhs(2, i1, i2, 26, q) = i2 + momrhs(1, i1, i2, 26, q) = -2d0 + i1 - 3d0*gam + momrhs(2, i1, i2, 26, q) = i2 momrhs(3, i1, i2, 26, q) = 3d0*gam - end if end if end do; end do @@ -402,20 +400,20 @@ contains do i = 1, nb bubrs(i) = bub_idx%rs(i) end do -!$acc update device(bubrs) + !$acc update device(bubrs) do j = 1, nmom do i = 1, nb bubmoms(i, j) = bub_idx%moms(i, j) end do end do -!$acc update device(bubmoms) + !$acc update device(bubmoms) end subroutine s_initialize_qbmm_module !Coefficient array for non-polytropic model (pb and mv values are accounted in wght_pb and wght_mv) - subroutine s_coeff_nonpoly(pres, rho, c, coeffs) -!$acc routine seq + subroutine s_coeff_nonpoly(pres, rho, c, coeffs) + !$acc routine seq real(kind(0.d0)), intent(INOUT) :: pres, rho, c real(kind(0.d0)), dimension(nterms, 0:2, 0:2), intent(OUT) :: coeffs integer :: i1, i2, q @@ -450,9 +448,9 @@ contains coeffs(13, i1, i2) = 0d0 coeffs(14, i1, i2) = 0d0 coeffs(15, i1, i2) = 0d0 - if(Re_inv /= dflt_real) coeffs(16, i1, i2) = -i2*4d0*Re_inv/rho - if(Web /= dflt_real) coeffs(17, i1, i2) = -i2*2d0/Web/rho - if(Re_inv /= dflt_real) then + if (Re_inv /= dflt_real) coeffs(16, i1, i2) = -i2*4d0*Re_inv/rho + if (Web /= dflt_real) coeffs(17, i1, i2) = -i2*2d0/Web/rho + if (Re_inv /= dflt_real) then coeffs(18, i1, i2) = i2*6d0*Re_inv/(rho*c) coeffs(19, i1, i2) = -i2*2d0*Re_inv/(rho*c*c) coeffs(20, i1, i2) = i2*4d0*pres*Re_inv/(rho*rho*c) @@ -460,20 +458,20 @@ contains coeffs(22, i1, i2) = -i2*4d0/(rho*rho*c) coeffs(23, i1, i2) = -i2*4d0/(rho*rho*c*c) coeffs(24, i1, i2) = i2*16d0*Re_inv*Re_inv/(rho*rho*c) - if(Web /= dflt_real) then + if (Web /= dflt_real) then coeffs(25, i1, i2) = i2*8d0*Re_inv/Web/(rho*rho*c) end if coeffs(26, i1, i2) = -12d0*i2*gam*Re_inv/(rho*rho*c*c) end if - coeffs(27, i1, i2) = 3d0*i2*gam*R_v*Tw / (c*rho) - coeffs(28, i1, i2) = 3d0*i2*gam*R_v*Tw / (c*c*rho) - if(Re_inv /= dflt_real) then - coeffs(29, i1, i2) = 12d0*i2*gam*R_v*Tw*Re_inv/(rho*rho*c*c) + coeffs(27, i1, i2) = 3d0*i2*gam*R_v*Tw/(c*rho) + coeffs(28, i1, i2) = 3d0*i2*gam*R_v*Tw/(c*c*rho) + if (Re_inv /= dflt_real) then + coeffs(29, i1, i2) = 12d0*i2*gam*R_v*Tw*Re_inv/(rho*rho*c*c) end if - coeffs(30, i1, i2) = 3d0*i2*gam / (c*rho) - coeffs(31, i1, i2) = 3d0*i2*gam / (c*c*rho) - if(Re_inv /= dflt_real) then - coeffs(32, i1, i2) = 12d0*i2*gam*Re_inv/(rho*rho*c*c) + coeffs(30, i1, i2) = 3d0*i2*gam/(c*rho) + coeffs(31, i1, i2) = 3d0*i2*gam/(c*c*rho) + if (Re_inv /= dflt_real) then + coeffs(32, i1, i2) = 12d0*i2*gam*Re_inv/(rho*rho*c*c) end if end if end if @@ -483,7 +481,7 @@ contains !Coefficient array for polytropic model (pb for each R0 bin accounted for in wght_pb) subroutine s_coeff(pres, rho, c, coeffs) -!$acc routine seq + !$acc routine seq real(kind(0.d0)), intent(INOUT) :: pres, rho, c real(kind(0.d0)), dimension(nterms, 0:2, 0:2), intent(OUT) :: coeffs integer :: i1, i2, q @@ -518,9 +516,9 @@ contains coeffs(13, i1, i2) = i2*(pv)/rho coeffs(14, i1, i2) = 2d0*i2*(pv)/(c*rho) coeffs(15, i1, i2) = i2*(pv)/(c*c*rho) - if(Re_inv /= dflt_real) coeffs(16, i1, i2) = -i2*4d0*Re_inv/rho - if(Web /= dflt_real) coeffs(17, i1, i2) = -i2*2d0/Web/rho - if(Re_inv /= dflt_real) then + if (Re_inv /= dflt_real) coeffs(16, i1, i2) = -i2*4d0*Re_inv/rho + if (Web /= dflt_real) coeffs(17, i1, i2) = -i2*2d0/Web/rho + if (Re_inv /= dflt_real) then coeffs(18, i1, i2) = i2*6d0*Re_inv/(rho*c) coeffs(19, i1, i2) = -i2*2d0*Re_inv/(rho*c*c) coeffs(20, i1, i2) = i2*4d0*pres*Re_inv/(rho*rho*c) @@ -528,7 +526,7 @@ contains coeffs(22, i1, i2) = -i2*4d0/(rho*rho*c) coeffs(23, i1, i2) = -i2*4d0/(rho*rho*c*c) coeffs(24, i1, i2) = i2*16d0*Re_inv*Re_inv/(rho*rho*c) - if(Web /= dflt_real) then + if (Web /= dflt_real) then coeffs(25, i1, i2) = i2*8d0*Re_inv/Web/(rho*rho*c) end if coeffs(26, i1, i2) = -12d0*i2*gam*Re_inv/(rho*rho*c*c) @@ -539,18 +537,18 @@ contains end subroutine s_coeff - subroutine s_mom_inv(q_cons_vf,q_prim_vf, momsp, moms3d, pb, rhs_pb, mv, rhs_mv, ix, iy, iz, nbub_sc) + subroutine s_mom_inv(q_cons_vf, q_prim_vf, momsp, moms3d, pb, rhs_pb, mv, rhs_mv, ix, iy, iz, nbub_sc) type(scalar_field), dimension(:), intent(INOUT) :: q_prim_vf, q_cons_vf type(scalar_field), dimension(:), intent(INOUT) :: momsp type(scalar_field), dimension(0:, 0:, :), intent(INOUT) :: moms3d - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: pb, mv - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: rhs_pb, rhs_mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: pb, mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: rhs_pb, rhs_mv real(kind(0d0)), dimension(startx:, starty:, startz:) :: nbub_sc type(int_bounds_info), intent(IN) :: ix, iy, iz real(kind(0d0)), dimension(nmom) :: moms, msum - real(kind(0d0)), dimension(nnode, nb) :: wght, abscX, abscY, wght_pb, wght_mv, wght_ht , ht + real(kind(0d0)), dimension(nnode, nb) :: wght, abscX, abscY, wght_pb, wght_mv, wght_ht, ht real(kind(0d0)), dimension(nterms, 0:2, 0:2) :: mom3d_terms, coeff real(kind(0d0)) :: pres, rho, nbub, c, alf, R3, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, T_bar, grad_T real(kind(0d0)) :: start, finish @@ -560,8 +558,7 @@ contains integer :: id1, id2, id3 integer :: i1, i2 - -!$acc parallel loop collapse(3) gang vector default(present) private(moms, msum, wght, abscX, abscY, wght_pb, wght_mv, wght_ht, coeff, ht, r, q, n_tait, B_tait, pres, rho, nbub, c, alf, R3, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, T_bar, grad_T) + !$acc parallel loop collapse(3) gang vector default(present) private(moms, msum, wght, abscX, abscY, wght_pb, wght_mv, wght_ht, coeff, ht, r, q, n_tait, B_tait, pres, rho, nbub, c, alf, R3, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, T_bar, grad_T) do id3 = iz%beg, iz%end do id2 = iy%beg, iy%end do id1 = ix%beg, ix%end @@ -572,8 +569,8 @@ contains if (bubble_model == 2) then n_tait = gammas(1) n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' - B_tait = pi_infs(1)*(n_tait - 1) / n_tait - c = n_tait*(pres + B_tait) * (1d0 - alf) /(rho) + B_tait = pi_infs(1)*(n_tait - 1)/n_tait + c = n_tait*(pres + B_tait)*(1d0 - alf)/(rho) if (c > 0.d0) then c = DSQRT(c) @@ -582,8 +579,7 @@ contains end if end if - - if(polytropic) then + if (polytropic) then call s_coeff(pres, rho, c, coeff) else call s_coeff_nonpoly(pres, rho, c, coeff) @@ -599,20 +595,20 @@ contains do q = 1, nb !Initialize moment set for each R0 bin !$acc loop seq - do r = 2, nmom - moms(r) = q_prim_vf(bubmoms(q, r))%sf(id1, id2, id3) + do r = 2, nmom + moms(r) = q_prim_vf(bubmoms(q, r))%sf(id1, id2, id3) end do moms(1) = 1d0 call s_chyqmom(moms, wght(:, q), abscX(:, q), abscY(:, q)) - if(polytropic) then + if (polytropic) then !Account for bubble pressure pb0 at each R0 bin !$acc loop seq - do j = 1, nnode - wght_pb(j, q) = wght(j, q) * (pb0(q) - pv) - end do + do j = 1, nnode + wght_pb(j, q) = wght(j, q)*(pb0(q) - pv) + end do else !Account for bubble pressure, mass transfer rate and heat transfer rate in wght_pb, wght_mv and wght_ht using Preston model !$acc loop seq @@ -620,20 +616,20 @@ contains chi_vw = 1.d0/(1.d0 + R_v/R_n*(pb(id1, id2, id3, j, q)/pv - 1.d0)) x_vw = M_n*chi_vw/(M_v + (M_n - M_v)*chi_vw) k_mw = x_vw*k_v(q)/(x_vw + (1.d0 - x_vw)*phi_vn) & - + (1.d0 - x_vw)*k_n(q)/(x_vw*phi_nv + 1.d0 - x_vw) + + (1.d0 - x_vw)*k_n(q)/(x_vw*phi_nv + 1.d0 - x_vw) rho_mw = pv/(chi_vw*R_v*Tw) - rhs_mv(id1, id2, id3, j, q) = - Re_trans_c(q)*( (mv(id1, id2, id3, j, q) / (mv(id1, id2, id3, j, q) + mass_n0(q))) - chi_vw) - rhs_mv(id1, id2, id3, j, q) = rho_mw*rhs_mv(id1, id2, id3, j, q) /Pe_c/(1.d0 - chi_vw)/ abscX(j, q) + rhs_mv(id1, id2, id3, j, q) = -Re_trans_c(q)*((mv(id1, id2, id3, j, q)/(mv(id1, id2, id3, j, q) + mass_n0(q))) - chi_vw) + rhs_mv(id1, id2, id3, j, q) = rho_mw*rhs_mv(id1, id2, id3, j, q)/Pe_c/(1.d0 - chi_vw)/abscX(j, q) - T_bar = Tw*(pb(id1, id2, id3, j, q)/pb0(q))*(abscX(j,q)/R0(q))**3 & + T_bar = Tw*(pb(id1, id2, id3, j, q)/pb0(q))*(abscX(j, q)/R0(q))**3 & *(mass_n0(q) + mass_v0(q))/(mass_n0(q) + mv(id1, id2, id3, j, q)) - grad_T = -Re_trans_T(q)*(T_bar - Tw) - ht(j, q) = pb0(q)*k_mw*grad_T/Pe_T(q)/abscX(j, q) + grad_T = -Re_trans_T(q)*(T_bar - Tw) + ht(j, q) = pb0(q)*k_mw*grad_T/Pe_T(q)/abscX(j, q) - wght_pb(j, q) = wght(j, q) * (pb(id1, id2, id3, j, q)) - wght_mv(j, q) = wght(j, q) * (rhs_mv(id1, id2, id3, j, q)) - wght_ht(j, q) = wght(j, q) * ht(j, q) - end do + wght_pb(j, q) = wght(j, q)*(pb(id1, id2, id3, j, q)) + wght_mv(j, q) = wght(j, q)*(rhs_mv(id1, id2, id3, j, q)) + wght_ht(j, q) = wght(j, q)*ht(j, q) + end do end if !Compute change in moments due to bubble dynamics @@ -647,29 +643,29 @@ contains !$acc loop seq do j = 1, nterms ! Account for term with pb in Rayleigh Plesset equation - if(bubble_model == 3 .and. j == 3 ) then - momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q)) & - *f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, q), momrhs(:, i1, i2, j, q)) - ! Account for terms with pb in Keller-Miksis equation - else if(bubble_model == 2 .and. ((j >= 7 .and. j <= 9) .or. (j >= 22 .and. j <= 23) .or. (j >= 10 .and. j <= 11) .or. (j == 26))) then - momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q)) & - *f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, q), momrhs(:, i1, i2, j, q)) - ! Account for terms with mass transfer rate in Keller-Miksis equation - else if(bubble_model == 2 .and. (j >= 27 .and. j <= 29) .and. (.not. polytropic)) then - momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q)) & - *f_quad2D(abscX(:, q), abscY(:, q), wght_mv(:, q), momrhs(:, i1, i2, j, q)) - ! Account for terms with heat transfer rate in Keller-Miksis equation - else if(bubble_model == 2 .and. (j >= 30 .and. j <= 32) .and. (.not. polytropic)) then - momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q)) & - *f_quad2D(abscX(:, q), abscY(:, q), wght_ht(:, q), momrhs(:, i1, i2, j, q)) + if (bubble_model == 3 .and. j == 3) then + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q)) & + *f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, q), momrhs(:, i1, i2, j, q)) + ! Account for terms with pb in Keller-Miksis equation + else if (bubble_model == 2 .and. ((j >= 7 .and. j <= 9) .or. (j >= 22 .and. j <= 23) .or. (j >= 10 .and. j <= 11) .or. (j == 26))) then + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q)) & + *f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, q), momrhs(:, i1, i2, j, q)) + ! Account for terms with mass transfer rate in Keller-Miksis equation + else if (bubble_model == 2 .and. (j >= 27 .and. j <= 29) .and. (.not. polytropic)) then + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q)) & + *f_quad2D(abscX(:, q), abscY(:, q), wght_mv(:, q), momrhs(:, i1, i2, j, q)) + ! Account for terms with heat transfer rate in Keller-Miksis equation + else if (bubble_model == 2 .and. (j >= 30 .and. j <= 32) .and. (.not. polytropic)) then + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q)) & + *f_quad2D(abscX(:, q), abscY(:, q), wght_ht(:, q), momrhs(:, i1, i2, j, q)) else - 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)) + 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 if end do - - moms3d(i1, i2, q)%sf(id1, id2, id3) = nbub * momsum + + moms3d(i1, i2, q)%sf(id1, id2, id3) = nbub*momsum msum(r) = momsum r = r + 1 @@ -678,56 +674,56 @@ contains end do ! Compute change in pb and mv for non-polytroic model - if(.not. polytropic) then - !$acc loop seq + if (.not. polytropic) then + !$acc loop seq do j = 1, nnode ! Compute Rdot (drdt) at quadrature node in the ODE for pb (note this is not the same as bubble variable Rdot) drdt = msum(2) - if(moms(4) - moms(2)**2d0 > 0d0) then - if(j == 1 .or. j == 2) then - drdt2 = -1d0 / (2d0 * dsqrt(moms(4) - moms(2)**2d0)) + if (moms(4) - moms(2)**2d0 > 0d0) then + if (j == 1 .or. j == 2) then + drdt2 = -1d0/(2d0*dsqrt(moms(4) - moms(2)**2d0)) else - drdt2 = 1d0 / (2d0 * dsqrt(moms(4) - moms(2)**2d0)) + drdt2 = 1d0/(2d0*dsqrt(moms(4) - moms(2)**2d0)) end if else ! Edge case where variance < 0 - if(j == 1 .or. j == 2) then - drdt2 = -1d0 / (2d0 * dsqrt(verysmall)) + if (j == 1 .or. j == 2) then + drdt2 = -1d0/(2d0*dsqrt(verysmall)) else - drdt2 = 1d0 / (2d0 * dsqrt(verysmall)) + drdt2 = 1d0/(2d0*dsqrt(verysmall)) end if end if - drdt2 = drdt2 * (msum(3) - 2d0 * moms(2) * msum(2)) + drdt2 = drdt2*(msum(3) - 2d0*moms(2)*msum(2)) drdt = drdt + drdt2 - rhs_pb(id1, id2, id3, j, q) = (-3d0*gam*drdt/ abscX(j, q)) * (pb(id1, id2, id3, j, q)) - rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3d0 * gam / abscX(j, q)) * rhs_mv(id1, id2, id3, j, q) * R_v * Tw - rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3d0 * gam / abscX(j, q)) * ht(j, q) - rhs_mv(id1, id2, id3, j, q) = rhs_mv(id1, id2, id3, j, q) * (4d0 * pi * abscX(j, q) ** 2d0) + rhs_pb(id1, id2, id3, j, q) = (-3d0*gam*drdt/abscX(j, q))*(pb(id1, id2, id3, j, q)) + rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3d0*gam/abscX(j, q))*rhs_mv(id1, id2, id3, j, q)*R_v*Tw + rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3d0*gam/abscX(j, q))*ht(j, q) + rhs_mv(id1, id2, id3, j, q) = rhs_mv(id1, id2, id3, j, q)*(4d0*pi*abscX(j, q)**2d0) end do - - end if + + end if end do ! Compute special high-order moments momsp(1)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght, 3d0, 0d0, 0d0) - momsp(2)%sf(id1, id2, id3) = 4.d0*pi*nbub* f_quad(abscX, abscY, wght, 2d0, 1d0, 0d0) + momsp(2)%sf(id1, id2, id3) = 4.d0*pi*nbub*f_quad(abscX, abscY, wght, 2d0, 1d0, 0d0) momsp(3)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght, 3d0, 2d0, 0d0) if (abs(gam - 1.d0) <= 1.d-4) then ! Gam \approx 1, don't risk imaginary quadrature momsp(4)%sf(id1, id2, id3) = 1.d0 else - !Special moment with bubble pressure pb - if(polytropic) then - momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3d0*(1d0 - gam), 0d0, 3d0*gam) + pv * f_quad(abscX, abscY, wght, 3d0, 0d0, 0d0) & - - 4d0*Re_inv*f_quad(abscX, abscY, wght, 2d0, 1d0, 0d0) - (2d0 / Web) * f_quad(abscX, abscY, wght, 2d0, 0d0, 0d0) + !Special moment with bubble pressure pb + if (polytropic) then + momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3d0*(1d0 - gam), 0d0, 3d0*gam) + pv*f_quad(abscX, abscY, wght, 3d0, 0d0, 0d0) & + - 4d0*Re_inv*f_quad(abscX, abscY, wght, 2d0, 1d0, 0d0) - (2d0/Web)*f_quad(abscX, abscY, wght, 2d0, 0d0, 0d0) else - momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3d0, 0d0, 0d0) & - - 4d0*Re_inv*f_quad(abscX, abscY, wght, 2d0, 1d0, 0d0) - (2d0 / Web) * f_quad(abscX, abscY, wght, 2d0, 0d0, 0d0) + momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3d0, 0d0, 0d0) & + - 4d0*Re_inv*f_quad(abscX, abscY, wght, 2d0, 1d0, 0d0) - (2d0/Web)*f_quad(abscX, abscY, wght, 2d0, 0d0, 0d0) end if end if - + else !$acc loop seq do q = 1, nb @@ -751,11 +747,10 @@ contains end do end do - end subroutine s_mom_inv subroutine s_chyqmom(momin, wght, abscX, abscY) -!$acc routine seq + !$acc routine seq real(kind(0d0)), dimension(nnode), intent(INOUT) :: wght, abscX, abscY real(kind(0d0)), dimension(nmom), intent(IN) :: momin @@ -778,11 +773,9 @@ contains d11 = moms(1, 1)/moms(0, 0) d02 = moms(0, 2)/moms(0, 0) - c20 = d20 - bu**2d0; c11 = d11 - bu*bv; c02 = d02 - bv**2d0; - M1 = (/1d0, 0d0, c20/) call s_hyqmom(myrho, up, M1) Vf = c11*up/c20 @@ -817,7 +810,6 @@ contains abscY(4) = Vf(2) + vp22 abscY = bv + abscY - end subroutine s_chyqmom subroutine s_hyqmom(frho, fup, fmom) diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 766322d0e..6480defd2 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -42,9 +42,9 @@ module m_rhs use m_monopole use m_viscous - + use m_nvtx - + use m_boundary_conditions ! ========================================================================== @@ -55,7 +55,6 @@ module m_rhs s_pressure_relaxation_procedure, & s_finalize_rhs_module - type(vector_field) :: q_cons_qp !< !! This variable contains the WENO-reconstructed values of the cell-average !! conservative variables, which are located in q_cons_vf, at cell-interior @@ -159,18 +158,18 @@ module m_rhs real(kind(0d0)), allocatable, dimension(:, :) :: Res !$acc declare create(Res) -!$acc declare create(q_cons_qp,q_prim_qp, & -!$acc dq_prim_dx_qp,dq_prim_dy_qp,dq_prim_dz_qp,dqL_prim_dx_n,dqL_prim_dy_n, & -!$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,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) + !$acc declare create(q_cons_qp,q_prim_qp, & + !$acc dq_prim_dx_qp,dq_prim_dy_qp,dq_prim_dz_qp,dqL_prim_dx_n,dqL_prim_dy_n, & + !$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,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 -!$acc declare create(nbub) + !$acc declare create(nbub) contains @@ -189,7 +188,7 @@ contains ix%end = m - ix%beg; iy%end = n - iy%beg; iz%end = p - iz%beg ! ================================================================== -!$acc update device(ix, iy, iz) + !$acc update device(ix, iy, iz) if (any(Re_size > 0) .and. cyl_coord) then @:ALLOCATE(tau_Re_vf(1:sys_size)) @@ -202,7 +201,7 @@ contains & iy%beg:iy%end, & & iz%beg:iz%end)) end if - + ixt = ix; iyt = iy; izt = iz @:ALLOCATE(q_cons_qp%vf(1:sys_size)) @@ -280,33 +279,33 @@ contains ! END: Allocation/Association of qK_cons_n and qK_prim_n ====== @:ALLOCATE(qL_rsx_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) + iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) @:ALLOCATE(qR_rsx_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) + iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) if (n > 0) then @:ALLOCATE(qL_rsy_vf(iy%beg:iy%end, & - ix%beg:ix%end, iz%beg:iz%end, 1:sys_size)) + ix%beg:ix%end, iz%beg:iz%end, 1:sys_size)) @:ALLOCATE(qR_rsy_vf(iy%beg:iy%end, & - ix%beg:ix%end, iz%beg:iz%end, 1:sys_size)) + ix%beg:ix%end, iz%beg:iz%end, 1:sys_size)) else @:ALLOCATE(qL_rsy_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) + iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) @:ALLOCATE(qR_rsy_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) + iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) end if if (p > 0) then @:ALLOCATE(qL_rsz_vf(iz%beg:iz%end, & - iy%beg:iy%end, ix%beg:ix%end, 1:sys_size)) + iy%beg:iy%end, ix%beg:ix%end, 1:sys_size)) @:ALLOCATE(qR_rsz_vf(iz%beg:iz%end, & - iy%beg:iy%end, ix%beg:ix%end, 1:sys_size)) + iy%beg:iy%end, ix%beg:ix%end, 1:sys_size)) else @:ALLOCATE(qL_rsz_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) + iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) @:ALLOCATE(qR_rsz_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) + iy%beg:iy%end, iz%beg:iz%end, 1:sys_size)) end if @@ -317,7 +316,7 @@ contains @:ALLOCATE(dq_prim_dx_qp%vf(1:sys_size)) @:ALLOCATE(dq_prim_dy_qp%vf(1:sys_size)) @:ALLOCATE(dq_prim_dz_qp%vf(1:sys_size)) - + if (any(Re_size > 0)) then do l = mom_idx%beg, mom_idx%end @@ -368,7 +367,7 @@ contains @:ALLOCATE(dqR_prim_dx_n(i)%vf(1:sys_size)) @:ALLOCATE(dqR_prim_dy_n(i)%vf(1:sys_size)) @:ALLOCATE(dqR_prim_dz_n(i)%vf(1:sys_size)) - + if (any(Re_size > 0)) then do l = mom_idx%beg, mom_idx%end @@ -417,34 +416,34 @@ contains if (any(Re_size > 0)) then if (weno_Re_flux) then @:ALLOCATE(dqL_rsx_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) + iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) @:ALLOCATE(dqR_rsx_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) + iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) if (n > 0) then @:ALLOCATE(dqL_rsy_vf(iy%beg:iy%end, & - ix%beg:ix%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) + ix%beg:ix%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) @:ALLOCATE(dqR_rsy_vf(iy%beg:iy%end, & - ix%beg:ix%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) + ix%beg:ix%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) else @:ALLOCATE(dqL_rsy_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) + iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) @:ALLOCATE(dqR_rsy_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%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(iz%beg:iz%end, & - iy%beg:iy%end, ix%beg:ix%end, mom_idx%beg:mom_idx%end)) + iy%beg:iy%end, ix%beg:ix%end, mom_idx%beg:mom_idx%end)) @:ALLOCATE(dqR_rsz_vf(iz%beg:iz%end, & - iy%beg:iy%end, ix%beg:ix%end, mom_idx%beg:mom_idx%end)) + iy%beg:iy%end, ix%beg:ix%end, mom_idx%beg:mom_idx%end)) else @:ALLOCATE(dqL_rsz_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) + iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) @:ALLOCATE(dqR_rsz_vf(ix%beg:ix%end, & - iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) + iy%beg:iy%end, iz%beg:iz%end, mom_idx%beg:mom_idx%end)) end if end if @@ -470,9 +469,9 @@ contains 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)) end if @:ALLOCATE(divu%sf(ix%beg:ix%end, iy%beg:iy%end, iz%beg:iz%end)) @@ -533,9 +532,9 @@ contains else do l = 1, sys_size @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf( & - ix%beg:ix%end, & - iy%beg:iy%end, & - iz%beg:iz%end)) + ix%beg:ix%end, & + iy%beg:iy%end, & + iz%beg:iz%end)) end do do l = 1, sys_size flux_n(i)%vf(l)%sf => & @@ -561,7 +560,7 @@ contains gamma_min(i) = 1d0/fluid_pp(i)%gamma + 1d0 pres_inf(i) = fluid_pp(i)%pi_inf/(1d0 + fluid_pp(i)%gamma) end do -!$acc update device(gamma_min, pres_inf) + !$acc update device(gamma_min, pres_inf) if (any(Re_size > 0)) then @:ALLOCATE(Res(1:2, 1:maxval(Re_size))) @@ -573,10 +572,9 @@ contains Res(i, j) = fluid_pp(Re_idx(i, j))%Re(i) end do end do -!$acc update device(Res, Re_idx, Re_size) + !$acc update device(Res, Re_idx, Re_size) end if - ! Associating procedural pointer to the subroutine that will be ! utilized to calculate the solution of a given Riemann problem if (riemann_solver == 1) then @@ -598,9 +596,7 @@ contains s_convert_species_to_mixture_variables end if - - -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do id = 1, num_dims do i = 1, sys_size do l = startz, p - startz @@ -624,10 +620,10 @@ contains type(scalar_field), dimension(sys_size), intent(INOUT) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(INOUT) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(INOUT) :: rhs_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: pb, mv - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent (INOUT) :: rhs_pb, rhs_mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: pb, mv + real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(INOUT) :: rhs_pb, rhs_mv 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 @@ -647,7 +643,7 @@ contains real(kind(0d0)) :: start, finish real(kind(0d0)) :: s2, const_sos, s1 - integer :: i, j, k, l, q, ii, id !< Generic loop iterators + integer :: i, j, k, l, q, ii, id !< Generic loop iterators integer :: term_index ! Configuring Coordinate Direction Indexes ========================= @@ -675,7 +671,7 @@ contains call nvtxStartRange("RHS-MPI") call s_populate_conservative_variables_buffers(Q_CONS_QP%VF, pb, mv) call nvtxEndRange - + ! ================================================================== ! Converting Conservative to Primitive Variables ================== @@ -708,26 +704,24 @@ contains gm_alpha_qp%vf, & ix, iy, iz) call nvtxEndRange - + if (t_step == t_step_stop) return ! ================================================================== if (qbmm) call s_mom_inv(q_cons_qp%vf, q_prim_qp%vf, mom_sp, mom_3d, pb, rhs_pb, mv, rhs_mv, ix, iy, iz, nbub) - - call nvtxStartRange("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, & - ix, iy, iz) + 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, & + ix, iy, iz) call nvtxEndRange() - + ! Dimensional Splitting Loop ======================================= do id = 1, num_dims @@ -740,9 +734,9 @@ contains 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( & @@ -782,7 +776,7 @@ contains qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & id) end if - + iv%beg = mom_idx%beg; iv%end = mom_idx%end if (weno_Re_flux) then call s_reconstruct_cell_boundary_values_visc_deriv( & @@ -894,46 +888,46 @@ contains end do end do - !Non-polytropic qbmm needs to account for change in bubble radius due to a change in nb - if(qbmm .and. (.not. polytropic) ) then + !Non-polytropic qbmm needs to account for change in bubble radius due to a change in nb + if (qbmm .and. (.not. polytropic)) then !$acc parallel loop collapse(5) gang vector default(present) private(nb_q, nR, nR2, R, R2, nb_dot, nR_dot, nR2_dot, var) do i = 1, nb do q = 1, nnode do l = 0, p do k = 0, n do j = 0, m - nb_q = q_cons_qp%vf(bubxb + (i-1)*nmom)%sf(j, k, l) - nR = q_cons_qp%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) - nR2 = q_cons_qp%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l) + nb_q = q_cons_qp%vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + nR = q_cons_qp%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + nR2 = q_cons_qp%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - R = q_prim_qp%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) - R2 = q_prim_qp%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l) + R = q_prim_qp%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + R2 = q_prim_qp%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - nb_dot = flux_n(1)%vf(bubxb + (i-1)*nmom)%sf(j - 1, k, l) - flux_n(1)%vf(bubxb + (i-1)*nmom)%sf(j , k, l) - nR_dot = flux_n(1)%vf(bubxb + 1 + (i-1)*nmom)%sf(j - 1, k, l) - flux_n(1)%vf(bubxb + 1 + (i-1)*nmom)%sf(j , k, l) - nR2_dot = flux_n(1)%vf(bubxb + 3 + (i-1)*nmom)%sf(j - 1, k, l) - flux_n(1)%vf(bubxb + 3 + (i-1)*nmom)%sf(j , k, l) + nb_dot = flux_n(1)%vf(bubxb + (i - 1)*nmom)%sf(j - 1, k, l) - flux_n(1)%vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + nR_dot = flux_n(1)%vf(bubxb + 1 + (i - 1)*nmom)%sf(j - 1, k, l) - flux_n(1)%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + nR2_dot = flux_n(1)%vf(bubxb + 3 + (i - 1)*nmom)%sf(j - 1, k, l) - flux_n(1)%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dx(j) * R * nb_q ** 2 )* & - (nR_dot * nb_q - nR * nb_dot) * (pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dx(j)*R*nb_q**2)* & + (nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) - if(R2 - R**2d0 > 0d0) then + if (R2 - R**2d0 > 0d0) then var = R2 - R**2d0 else var = verysmall end if - - if(q <= 2) then - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0 * gam/ (dx(j) * R * nb_q ** 2 * dsqrt(var)) * & - (nR2_dot * nb_q - nR2 * nb_dot ) * (pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0 * gam/ (dx(j) * R * nb_q ** 2 * dsqrt(var)) * & - ( - 2d0 * (nR / nb_q) * (nR_dot * nb_q - nR * nb_dot )) * (pb(j, k, l, q, i)) + + if (q <= 2) then + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dx(j)*R*nb_q**2*dsqrt(var))* & + (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dx(j)*R*nb_q**2*dsqrt(var))* & + (-2d0*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) else - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dx(j) * R * nb_q ** 2 * dsqrt(var)) * & - (nR2_dot * nb_q - nR2 * nb_dot ) * (pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dx(j) * R * nb_q ** 2 * dsqrt(var)) * & - ( - 2d0 * (nR / nb_q) * (nR_dot * nb_q - nR * nb_dot )) * (pb(j, k, l, q, i)) - end if + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dx(j)*R*nb_q**2*dsqrt(var))* & + (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dx(j)*R*nb_q**2*dsqrt(var))* & + (-2d0*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + end if end do end do @@ -1036,8 +1030,8 @@ contains end do end do end do - else - !$acc parallel loop collapse(3) gang vector default(present) + else + !$acc parallel loop collapse(3) gang vector default(present) do l = 0, p do k = 0, n do j = 0, m @@ -1052,19 +1046,19 @@ contains 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) + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, rhs_vf) end if end if - end if + end if if (monopole) then ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 - if (id == ndirs) then + 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) + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, & + rhs_vf) end if end if @@ -1130,46 +1124,46 @@ contains end do end do end do - !Non-polytropic qbmm needs to account for change in bubble radius due to a change in nb - if(qbmm .and. (.not. polytropic) ) then + !Non-polytropic qbmm needs to account for change in bubble radius due to a change in nb + if (qbmm .and. (.not. polytropic)) then !$acc parallel loop collapse(5) gang vector default(present) private(nb_q, nR, nR2, R, R2, nb_dot, nR_dot, nR2_dot, var) do i = 1, nb do q = 1, nnode do l = 0, p do k = 0, n do j = 0, m - nb_q = q_cons_qp%vf(bubxb + (i-1)*nmom)%sf(j, k, l) - nR = q_cons_qp%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) - nR2 = q_cons_qp%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l) + nb_q = q_cons_qp%vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + nR = q_cons_qp%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + nR2 = q_cons_qp%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - R = q_prim_qp%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) - R2 = q_prim_qp%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l) + R = q_prim_qp%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + R2 = q_prim_qp%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - nb_dot = flux_n(2)%vf(bubxb + (i-1)*nmom)%sf(j, k - 1, l) - flux_n(2)%vf(bubxb + (i-1)*nmom)%sf(j , k, l) - nR_dot = flux_n(2)%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k - 1, l) - flux_n(2)%vf(bubxb + 1 + (i-1)*nmom)%sf(j , k, l) - nR2_dot = flux_n(2)%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k - 1, l) - flux_n(2)%vf(bubxb + 3 + (i-1)*nmom)%sf(j , k, l) + nb_dot = flux_n(2)%vf(bubxb + (i - 1)*nmom)%sf(j, k - 1, l) - flux_n(2)%vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + nR_dot = flux_n(2)%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k - 1, l) - flux_n(2)%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + nR2_dot = flux_n(2)%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k - 1, l) - flux_n(2)%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dy(k) * R * nb_q ** 2 )* & - (nR_dot * nb_q - nR * nb_dot) * (pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dy(k)*R*nb_q**2)* & + (nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) - if(R2 - R**2d0 > 0d0) then + if (R2 - R**2d0 > 0d0) then var = R2 - R**2d0 else var = verysmall end if - - if(q <= 2) then - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0 * gam/ (dy(k) * R * nb_q ** 2 * dsqrt(var)) * & - (nR2_dot * nb_q - nR2 * nb_dot ) * (pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0 * gam/ (dy(k) * R * nb_q ** 2 * dsqrt(var)) * & - ( - 2d0 * (nR / nb_q) * (nR_dot * nb_q - nR * nb_dot )) * (pb(j, k, l, q, i)) + + if (q <= 2) then + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dy(k)*R*nb_q**2*dsqrt(var))* & + (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dy(k)*R*nb_q**2*dsqrt(var))* & + (-2d0*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) else - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dy(k) * R * nb_q ** 2 * dsqrt(var)) * & - (nR2_dot * nb_q - nR2 * nb_dot ) * (pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dy(k) * R * nb_q ** 2 * dsqrt(var)) * & - ( - 2d0 * (nR / nb_q) * (nR_dot * nb_q - nR * nb_dot )) * (pb(j, k, l, q, i)) - end if + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dy(k)*R*nb_q**2*dsqrt(var))* & + (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dy(k)*R*nb_q**2*dsqrt(var))* & + (-2d0*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + end if end do end do @@ -1256,7 +1250,7 @@ contains end if end do else - !$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do j = advxb, advxe do l = 0, p do k = 0, n @@ -1288,21 +1282,19 @@ contains 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) + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, rhs_vf) end if end if - - if (monopole) then ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 - if (id == ndirs) then + 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) + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, & + rhs_vf) end if end if @@ -1502,51 +1494,51 @@ contains end do end do end do - !Non-polytropic qbmm needs to account for change in bubble radius due to a change in nb - if(qbmm .and. (.not. polytropic)) then - !$acc parallel loop collapse(5) gang vector default(present) private(nb_q, nR, nR2, R, R2, nb_dot, nR_dot, nR2_dot, var) + !Non-polytropic qbmm needs to account for change in bubble radius due to a change in nb + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) private(nb_q, nR, nR2, R, R2, nb_dot, nR_dot, nR2_dot, var) do i = 1, nb do q = 1, nnode do l = 0, p do k = 0, n do j = 0, m - nb_q = q_cons_qp%vf(bubxb + (i-1)*nmom)%sf(j, k, l) - nR = q_cons_qp%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) - nR2 = q_cons_qp%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l) + nb_q = q_cons_qp%vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + nR = q_cons_qp%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + nR2 = q_cons_qp%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - R = q_prim_qp%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) - R2 = q_prim_qp%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l) + R = q_prim_qp%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + R2 = q_prim_qp%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - nb_dot = q_prim_qp%vf(contxe + id)%sf(j, k, l) * (flux_n(3)%vf(bubxb + (i-1)*nmom)%sf(j, k, l - 1) - flux_n(3)%vf(bubxb + (i-1)*nmom)%sf(j , k, l)) - nR_dot = q_prim_qp%vf(contxe + id)%sf(j, k, l) * (flux_n(3)%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l - 1) - flux_n(3)%vf(bubxb + 1 + (i-1)*nmom)%sf(j , k, l)) - nR2_dot = q_prim_qp%vf(contxe + id)%sf(j, k, l) * (flux_n(3)%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l - 1 ) - flux_n(3)%vf(bubxb + 3 + (i-1)*nmom)%sf(j , k, l)) + nb_dot = q_prim_qp%vf(contxe + id)%sf(j, k, l)*(flux_n(3)%vf(bubxb + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n(3)%vf(bubxb + (i - 1)*nmom)%sf(j, k, l)) + nR_dot = q_prim_qp%vf(contxe + id)%sf(j, k, l)*(flux_n(3)%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n(3)%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)) + nR2_dot = q_prim_qp%vf(contxe + id)%sf(j, k, l)*(flux_n(3)%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n(3)%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dz(l) * y_cc(k) * R * nb_q ** 2 )* & - (nR_dot * nb_q - nR * nb_dot) * (pb(j, k, l, q, i)) - if(R2 - R**2d0 > 0d0) then + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dz(l)*y_cc(k)*R*nb_q**2)* & + (nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + if (R2 - R**2d0 > 0d0) then var = R2 - R**2d0 else var = verysmall end if - - if(q <= 2) then - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0 * gam/ (dz(l) * y_cc(k) * R * nb_q ** 2 * dsqrt(var)) * & - (nR2_dot * nb_q - nR2 * nb_dot ) * (pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0 * gam/ (dz(l) * y_cc(k) * R * nb_q ** 2 * dsqrt(var)) * & - ( - 2d0 * (nR / nb_q) * (nR_dot * nb_q - nR * nb_dot )) * (pb(j, k, l, q, i)) + + if (q <= 2) then + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dz(l)*y_cc(k)*R*nb_q**2*dsqrt(var))* & + (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dz(l)*y_cc(k)*R*nb_q**2*dsqrt(var))* & + (-2d0*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) else - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dz(l) * y_cc(k) * R * nb_q ** 2 * dsqrt(var)) * & - (nR2_dot * nb_q - nR2 * nb_dot ) * (pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dz(l) * y_cc(k) * R * nb_q ** 2 * dsqrt(var)) * & - ( - 2d0 * (nR / nb_q) * (nR_dot * nb_q - nR * nb_dot )) * (pb(j, k, l, q, i)) - end if + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dz(l)*y_cc(k)*R*nb_q**2*dsqrt(var))* & + (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dz(l)*y_cc(k)*R*nb_q**2*dsqrt(var))* & + (-2d0*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + end if end do end do end do end do end do - end if + end if if (riemann_solver == 1) then do j = advxb, advxe @@ -1640,46 +1632,46 @@ contains end do end do end do - !Non-polytropic qbmm needs to account for change in bubble radius due to a change in nb - if(qbmm .and. (.not. polytropic) ) then - !$acc parallel loop collapse(5) gang vector default(present) private(nb_q, nR, nR2, R, R2, nb_dot, nR_dot, nR2_dot, var) + !Non-polytropic qbmm needs to account for change in bubble radius due to a change in nb + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) private(nb_q, nR, nR2, R, R2, nb_dot, nR_dot, nR2_dot, var) do i = 1, nb do q = 1, nnode do l = 0, p do k = 0, n do j = 0, m - nb_q = q_cons_qp%vf(bubxb + (i-1)*nmom)%sf(j, k, l) - nR = q_cons_qp%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) - nR2 = q_cons_qp%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l) + nb_q = q_cons_qp%vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + nR = q_cons_qp%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + nR2 = q_cons_qp%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - R = q_prim_qp%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l) - R2 = q_prim_qp%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l) + R = q_prim_qp%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + R2 = q_prim_qp%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - nb_dot = flux_n(3)%vf(bubxb + (i-1)*nmom)%sf(j, k, l - 1) - flux_n(3)%vf(bubxb + (i-1)*nmom)%sf(j , k, l) - nR_dot = flux_n(3)%vf(bubxb + 1 + (i-1)*nmom)%sf(j, k, l - 1) - flux_n(3)%vf(bubxb + 1 + (i-1)*nmom)%sf(j , k, l) - nR2_dot = flux_n(3)%vf(bubxb + 3 + (i-1)*nmom)%sf(j, k, l - 1 ) - flux_n(3)%vf(bubxb + 3 + (i-1)*nmom)%sf(j , k, l) + nb_dot = flux_n(3)%vf(bubxb + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n(3)%vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + nR_dot = flux_n(3)%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n(3)%vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + nR2_dot = flux_n(3)%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n(3)%vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dz(l) * R * nb_q ** 2 )* & - (nR_dot * nb_q - nR * nb_dot) * (pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dz(l)*R*nb_q**2)* & + (nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) - if(R2 - R**2d0 > 0d0) then + if (R2 - R**2d0 > 0d0) then var = R2 - R**2d0 else var = verysmall end if - - if(q <= 2) then - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0 * gam/ (dz(l) * R * nb_q ** 2 * dsqrt(var)) * & - (nR2_dot * nb_q - nR2 * nb_dot ) * (pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0 * gam/ (dz(l) * R * nb_q ** 2 * dsqrt(var)) * & - ( - 2d0 * (nR / nb_q) * (nR_dot * nb_q - nR * nb_dot )) * (pb(j, k, l, q, i)) + + if (q <= 2) then + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dz(l)*R*nb_q**2*dsqrt(var))* & + (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dz(l)*R*nb_q**2*dsqrt(var))* & + (-2d0*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) else - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dz(l) * R * nb_q ** 2 * dsqrt(var)) * & - (nR2_dot * nb_q - nR2 * nb_dot ) * (pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0 * gam/ (dz(l) * R * nb_q ** 2 * dsqrt(var)) * & - ( - 2d0 * (nR / nb_q) * (nR_dot * nb_q - nR * nb_dot )) * (pb(j, k, l, q, i)) - end if + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dz(l)*R*nb_q**2*dsqrt(var))* & + (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3d0*gam/(dz(l)*R*nb_q**2*dsqrt(var))* & + (-2d0*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + end if end do end do @@ -1770,9 +1762,9 @@ contains 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) + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, rhs_vf) end if end if @@ -1782,10 +1774,10 @@ contains if (monopole) then ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 - if (id == ndirs) then + 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) + q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), t_step, id, & + rhs_vf) end if end if @@ -1885,7 +1877,6 @@ contains end subroutine s_compute_rhs ! ----------------------------------------- - !> 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 @@ -2150,7 +2141,7 @@ contains !! the values at the quadrature points, of the cell-average variables !! @param norm_dir Splitting coordinate direction subroutine s_reconstruct_cell_boundary_values(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, & ! - - norm_dir) + norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(IN) :: v_vf @@ -2184,21 +2175,21 @@ contains 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) + 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) + 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) + norm_dir, weno_dir, & + is1, is2, is3) end if ! ================================================================== diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 4319f0c7a..1d3fc7c88 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -37,10 +37,10 @@ module m_riemann_solvers implicit none private; public :: s_initialize_riemann_solvers_module, & - s_riemann_solver, & - s_hll_riemann_solver, & - s_hllc_riemann_solver, & - s_finalize_riemann_solvers_module + s_riemann_solver, & + s_hll_riemann_solver, & + s_hllc_riemann_solver, & + s_finalize_riemann_solvers_module abstract interface ! ======================================================= @@ -161,7 +161,6 @@ module m_riemann_solvers !$acc declare create( flux_rsx_vf, flux_src_rsx_vf, flux_rsy_vf, & !$acc flux_src_rsy_vf, flux_rsz_vf, flux_src_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. @@ -205,10 +204,9 @@ module m_riemann_solvers type(int_bounds_info) :: isx, isy, isz !> @} !$acc declare create(is1, is2, is3, isx, isy, isz) - - real(kind(0d0)), allocatable, dimension(:) :: Gs - !$acc declare create(Gs) + real(kind(0d0)), allocatable, dimension(:) :: Gs + !$acc declare create(Gs) real(kind(0d0)), allocatable, dimension(:, :) :: Res !$acc declare create(Res) @@ -454,20 +452,20 @@ contains end if end do end if - + @:compute_average_state() call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, c_L) + vel_L_rms, c_L) call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, c_R) + vel_R_rms, c_R) !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. + ! variables are placeholders to call the subroutine. call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, c_avg) + vel_avg_rms, c_avg) if (any(Re_size > 0)) then !$acc loop seq @@ -862,8 +860,8 @@ contains if (model_eqns == 3) then !ME3 -!$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R, & -!$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, vel_avg_rms, alpha_L, alpha_R) + !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R, & + !$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, vel_avg_rms, alpha_L, alpha_R) do l = is3%beg, is3%end do k = is2%beg, is2%end @@ -980,16 +978,16 @@ contains @:compute_average_state() call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, c_L) + vel_L_rms, c_L) call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, c_R) + vel_R_rms, c_R) !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. + ! variables are placeholders to call the subroutine. call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, c_avg) + vel_avg_rms, c_avg) if (any(Re_size > 0)) then !$acc loop seq @@ -1041,10 +1039,10 @@ contains qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1)*vel_L(dir_idx(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) ) + & - qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1) * & - qvs(i) ) * vel_L(dir_idx(1) ) + (qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1)* & + (gammas(i)*pres_L + pi_infs(i)) + & + qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1)* & + qvs(i))*vel_L(dir_idx(1)) end do !$acc loop seq do i = 1, num_dims @@ -1052,7 +1050,7 @@ contains rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L 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))) + 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(j, k, l, E_idx) = (E_L + pres_L)*vel_L(dir_idx(1)) @@ -1070,10 +1068,10 @@ contains qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1)*vel_R(dir_idx(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) ) + & - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1) * & - qvs(i) ) * vel_R(dir_idx(1)) + (qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)* & + (gammas(i)*pres_R + pi_infs(i)) + & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1)* & + qvs(i))*vel_R(dir_idx(1)) end do !$acc loop seq do i = 1, num_dims @@ -1081,7 +1079,7 @@ contains rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*pres_R 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))) + 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(j, k, l, E_idx) = (E_R + pres_R)*vel_R(dir_idx(1)) @@ -1105,10 +1103,10 @@ contains qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1)*xi_L*s_S 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) ) + & - qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1) * & - qvs(i) ) * s_S + (qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1)* & + (gammas(i)*p_K_Star + pi_infs(i)) + & + qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1)* & + qvs(i))*s_S end do !$acc loop seq do i = 1, num_dims @@ -1117,7 +1115,7 @@ contains (1d0 - dir_flg(dir_idx(i)))) + dir_flg(dir_idx(i))*p_Star 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))) + 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(j, k, l, E_idx) = (E_Star + p_Star)*s_S @@ -1144,19 +1142,19 @@ contains qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1)*xi_R*s_S 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) ) + & - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1) * & - qvs(i) ) * s_S + (qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)* & + (gammas(i)*p_K_Star + pi_infs(i)) + & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1)* & + qvs(i))*s_S end do !$acc loop seq do i = 1, num_dims 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 + (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(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))) + 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 @@ -1259,16 +1257,16 @@ contains @:compute_average_state() call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, c_L) + vel_L_rms, c_L) call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, c_R) + vel_R_rms, c_R) !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. + ! variables are placeholders to call the subroutine. call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, c_avg) + vel_avg_rms, c_avg) if (wave_speeds == 1) then s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) @@ -1348,9 +1346,9 @@ contains ! Put p_tilde in !$acc loop seq do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) + & - xi_M*(dir_flg(dir_idx(i))*(-1d0*ptilde_L)) & + xi_M*(dir_flg(dir_idx(i))*(-1d0*ptilde_L)) & + xi_P*(dir_flg(dir_idx(i))*(-1d0*ptilde_R)) end do end if @@ -1439,9 +1437,9 @@ contains 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, alpha_L, alpha_R, h_avg, gamma_avg, s_L, s_R, s_S, nbub_L, nbub_R, ptilde_L, ptilde_R, vel_avg_rms, Re_L, Re_R) do l = is3%beg, is3%end do k = is2%beg, is2%end @@ -1532,8 +1530,8 @@ contains !$acc loop seq do q = 1, Re_size(i) - Re_L(i) = (1d0-qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & - + Re_L(i) + Re_L(i) = (1d0 - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + + Re_L(i) end do Re_L(i) = 1d0/max(Re_L(i), sgm_eps) @@ -1548,15 +1546,15 @@ contains !$acc loop seq do q = 1, Re_size(i) - Re_R(i) = (1d0-qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & - + Re_R(i) + Re_R(i) = (1d0 - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + + Re_R(i) end do Re_R(i) = 1d0/max(Re_R(i), sgm_eps) end do - end if + end if end if - + E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*rho_R*vel_R_rms @@ -1577,7 +1575,7 @@ contains end if end do - if(.not. qbmm) then + if (.not. qbmm) then nbub_L_denom = 0d0 nbub_R_denom = 0d0 !$acc loop seq @@ -1586,7 +1584,7 @@ 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(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 + nbub_R = (3.d0/(4.d0*pi))*qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom else !nb stored in 0th moment of first R0 bin in variable conversion module nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, bubxb) @@ -1643,16 +1641,14 @@ contains ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*pres_L else ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*(pres_L - PbwR3Lbar/R3Lbar - & - rho_L*R3V2Lbar/R3Lbar) + rho_L*R3V2Lbar/R3Lbar) end if - - - if (qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids) < small_alf .or. R3Rbar < small_alf) then + 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(j + 1, k, l, E_idx + num_fluids)*(pres_R - PbwR3Rbar/R3Rbar - & - rho_R*R3V2Rbar/R3Rbar) + rho_R*R3V2Rbar/R3Rbar) end if if ((ptilde_L /= ptilde_L) .or. (ptilde_R /= ptilde_R)) then @@ -1671,16 +1667,16 @@ contains end if call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, c_L) + vel_L_rms, c_L) call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, c_R) + vel_R_rms, c_R) !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. + ! variables are placeholders to call the subroutine. call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, c_avg) + vel_avg_rms, c_avg) if (any(Re_size > 0)) then !$acc loop seq @@ -1785,7 +1781,6 @@ contains (rho_R*s_S + (pres_R - ptilde_R)/ & (s_R - vel_R(dir_idx(1))))) - E_R)) - ! Volume fraction flux !$acc loop seq @@ -1815,7 +1810,7 @@ contains ! Add advection flux for bubble variables !$acc loop seq - do i = bubxb , bubxe + do i = bubxb, bubxe 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)) & @@ -1823,12 +1818,12 @@ contains *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do - if(qbmm) then + if (qbmm) then flux_rs${XYZ}$_vf(j, k, l, bubxb) = & - xi_M*nbub_L & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & - + xi_P*nbub_R & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) + xi_M*nbub_L & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + + xi_P*nbub_R & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end if ! Geometrical source flux for cylindrical coordinates @@ -1928,25 +1923,25 @@ contains !$acc loop seq do i = 1, num_fluids 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) + 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(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(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(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) + 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(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) + 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 @@ -2006,16 +2001,16 @@ contains @:compute_average_state() call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, c_L) + vel_L_rms, c_L) call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, c_R) + vel_R_rms, c_R) !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. + ! variables are placeholders to call the subroutine. call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, c_avg) + vel_avg_rms, c_avg) if (any(Re_size > 0)) then !$acc loop seq @@ -2113,8 +2108,6 @@ contains (rho_R*s_S + pres_R/ & (s_R - vel_R(idx1)))) - E_R)) - - ! Volume fraction flux !$acc loop seq do i = advxb, advxe @@ -2232,7 +2225,6 @@ contains end subroutine s_hllc_riemann_solver - !> The computation of parameters, the allocation of memory, !! the association of pointers and/or the execution of any !! other procedures that are necessary to setup the module. @@ -2250,7 +2242,6 @@ contains end do !$acc update device(Gs) - if (any(Re_size > 0)) then allocate (Res(1:2, 1:maxval(Re_size))) end if @@ -2264,7 +2255,6 @@ contains !$acc update device(Res, Re_idx, Re_size) end if - ! Associating procedural pointer to the subroutine that will be ! utilized to calculate the solution of a given Riemann problem if (riemann_solver == 1) then @@ -2285,25 +2275,25 @@ contains is1%end = m; is2%end = n; is3%end = p allocate (flux_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + allocate (flux_gsrc_rsx_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) - 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(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) + is2%beg:is2%end, & + is3%beg:is3%end, advxb:sys_size)) allocate (vel_src_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_dims)) + is2%beg:is2%end, & + is3%beg:is3%end, 1:num_dims)) if (qbmm) then 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(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) + is2%beg:is2%end, & + is3%beg:is3%end, 1:2)) end if if (n == 0) return @@ -2312,17 +2302,17 @@ contains is1%end = n; is2%end = m; is3%end = p allocate (flux_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + allocate (flux_gsrc_rsy_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) - 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(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) + is2%beg:is2%end, & + is3%beg:is3%end, advxb:sys_size)) allocate (vel_src_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_dims)) + is2%beg:is2%end, & + is3%beg:is3%end, 1:num_dims)) if (qbmm) then allocate (mom_sp_rsy_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) @@ -2330,8 +2320,8 @@ contains if (any(Re_size > 0)) then allocate (Re_avg_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) + is2%beg:is2%end, & + is3%beg:is3%end, 1:2)) end if if (p == 0) return @@ -2340,17 +2330,17 @@ contains is1%end = p; is2%end = n; is3%end = m allocate (flux_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + allocate (flux_gsrc_rsz_vf(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) - 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(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) + is2%beg:is2%end, & + is3%beg:is3%end, advxb:sys_size)) allocate (vel_src_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_dims)) + is2%beg:is2%end, & + is3%beg:is3%end, 1:num_dims)) if (qbmm) then allocate (mom_sp_rsz_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) @@ -2358,8 +2348,8 @@ contains if (any(Re_size > 0)) then allocate (Re_avg_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) + is2%beg:is2%end, & + is3%beg:is3%end, 1:2)) end if end subroutine s_initialize_riemann_solvers_module ! ------------------- diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index eac47bcd3..cd812be58 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -13,9 +13,9 @@ !! contain the inputs, the initial condition data and the grid data !! that are provided by the user. The module is additionally tasked !! with verifying the consistency of the user inputs and completing -!! the grid variables. This module also also allocating, initializing -!! I/O, and deallocating the relevant variables on both cpus and gpus as well as -!! setting up the time stepping, domain decomposition and I/O procedures. +!! the grid variables. This module also also allocating, initializing +!! I/O, and deallocating the relevant variables on both cpus and gpus as well as +!! setting up the time stepping, domain decomposition and I/O procedures. module m_start_up ! Dependencies ============================================================= @@ -72,17 +72,17 @@ module m_start_up implicit none - private; public :: s_read_input_file, & - s_check_input_file, & - s_read_data_files, & - s_read_serial_data_files, & - s_read_parallel_data_files, & - s_populate_grid_variables_buffers, & - s_initialize_internal_energy_equations, & - s_initialize_modules, s_initialize_gpu_vars, & - s_initialize_mpi_domain, s_finalize_modules, & - s_perform_time_step, s_save_data, & - s_save_performance_metrics + private; public :: s_read_input_file, & + s_check_input_file, & + s_read_data_files, & + s_read_serial_data_files, & + s_read_parallel_data_files, & + s_populate_grid_variables_buffers, & + s_initialize_internal_energy_equations, & + s_initialize_modules, s_initialize_gpu_vars, & + s_initialize_mpi_domain, s_finalize_modules, & + s_perform_time_step, s_save_data, & + s_save_performance_metrics abstract interface ! =================================================== @@ -125,7 +125,7 @@ contains namelist /user_inputs/ case_dir, run_time_info, m, n, p, dt, & t_step_start, t_step_stop, t_step_save, & model_eqns, num_fluids, adv_alphan, & - mpp_lim, time_stepper, weno_eps, weno_flat, & + mpp_lim, time_stepper, weno_eps, weno_flat, & riemann_flat, cu_mpi, cu_tensor, & mapped_weno, mp_weno, weno_avg, & riemann_solver, wave_speeds, avg_state, & @@ -145,7 +145,7 @@ contains polytropic, thermal, & integral, integral_wrt, num_integrals, & polydisperse, poly_sigma, qbmm, & - R0_type, file_per_process, relax, relax_model, & + R0_type, file_per_process, relax, relax_model, & palpha_eps, ptgalpha_eps ! Checking that an input file has been provided by the user. If it @@ -160,11 +160,11 @@ contains read (1, NML=user_inputs, iostat=iostatus) if (iostatus /= 0) then - backspace(1) - read(1,fmt='(A)') line - print*, 'Invalid line in namelist: '//trim(line) + backspace (1) + read (1, fmt='(A)') line + print *, 'Invalid line in namelist: '//trim(line) call s_mpi_abort('Invalid line in pre_process.inp. It is '// & - 'likely due to a datatype mismatch. Exiting ...') + 'likely due to a datatype mismatch. Exiting ...') end if close (1) @@ -237,7 +237,7 @@ contains file_path = trim(t_step_dir)//'/.' call my_inquire(file_path, file_exist) - if (file_exist .neqv. .true.) then + if (file_exist .neqv. .true.) then call s_mpi_abort(trim(file_path)//' is missing. Exiting ...') end if @@ -339,11 +339,11 @@ contains end if end do !Read pb and mv for non-polytropic qbmm - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A)') & - trim(t_step_dir)//'/pb', sys_size + (i-1)*nnode + r, '.dat' + trim(t_step_dir)//'/pb', sys_size + (i - 1)*nnode + r, '.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then open (2, FILE=trim(file_path), & @@ -355,11 +355,11 @@ contains call s_mpi_abort(trim(file_path)//' is missing. Exiting ...') end if end do - end do + end do do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A)') & - trim(t_step_dir)//'/mv', sys_size + (i-1)*nnode + r , '.dat' + trim(t_step_dir)//'/mv', sys_size + (i - 1)*nnode + r, '.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then open (2, FILE=trim(file_path), & @@ -371,7 +371,7 @@ contains call s_mpi_abort(trim(file_path)//' is missing. Exiting ...') end if end do - end do + end do end if end if ! ================================================================== @@ -400,7 +400,7 @@ contains character(LEN=path_len + 2*name_len) :: file_loc logical :: file_exist - character(len = 10) :: t_step_start_string + character(len=10) :: t_step_start_string integer :: i @@ -460,7 +460,7 @@ contains call MPI_FILE_READ(ifile, z_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort( 'File '//trim(file_loc)//'is missing. Exiting...') + call s_mpi_abort('File '//trim(file_loc)//'is missing. Exiting...') end if ! Assigning local cell boundary locations @@ -506,15 +506,15 @@ contains var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + MPI_DOUBLE_PRECISION, status, ierr) end do !Read pb and mv for non-polytropic qbmm - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + MPI_DOUBLE_PRECISION, status, ierr) end do end if else @@ -522,7 +522,7 @@ contains var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + MPI_DOUBLE_PRECISION, status, ierr) end do end if @@ -566,21 +566,21 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + MPI_DOUBLE_PRECISION, status, ierr) end do !Read pb and mv for non-polytropic qbmm - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + MPI_DOUBLE_PRECISION, status, ierr) end do end if else @@ -591,9 +591,9 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) + 'native', mpi_info_int, ierr) call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + MPI_DOUBLE_PRECISION, status, ierr) end do end if @@ -854,7 +854,7 @@ contains end do call s_compute_pressure(v_vf(E_idx)%sf(j, k, l), 0d0, & - dyn_pres, pi_inf, gamma, rho, qv, pres) + dyn_pres, pi_inf, gamma, rho, qv, pres) do i = 1, num_fluids v_vf(i + internalEnergies_idx%beg - 1)%sf(j, k, l) = v_vf(i + adv_idx%beg - 1)%sf(j, k, l)* & @@ -872,8 +872,8 @@ contains integer, intent(INOUT) :: t_step real(kind(0d0)), intent(INOUT) :: time_avg, time_final real(kind(0d0)), intent(INOUT) :: io_time_avg, io_time_final - real(kind(0d0)), dimension(:), intent(INOUT) :: proc_time - real(kind(0d0)), dimension(:), intent(INOUT) :: io_proc_time + real(kind(0d0)), dimension(:), intent(INOUT) :: proc_time + real(kind(0d0)), dimension(:), intent(INOUT) :: io_proc_time logical, intent(INOUT) :: file_exists real(kind(0d0)), intent(INOUT) :: start, finish integer, intent(INOUT) :: nt @@ -881,11 +881,11 @@ contains integer :: i, j, k, l if (proc_rank == 0) then - print '(" ["I3"%] Time step "I8" of "I0" @ t_step = "I0"")', & - int(ceiling(100d0*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), & - t_step - t_step_start + 1, & - t_step_stop - t_step_start + 1, & - t_step + print '(" ["I3"%] Time step "I8" of "I0" @ t_step = "I0"")', & + int(ceiling(100d0*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), & + t_step - t_step_start + 1, & + t_step_stop - t_step_start + 1, & + t_step end if mytime = mytime + dt @@ -910,10 +910,10 @@ contains call s_3rd_order_tvd_rk(t_step, time_avg) end if - if ( relax ) call s_relaxation_solver(q_cons_ts(1)%vf) + if (relax) call s_relaxation_solver(q_cons_ts(1)%vf) ! Time-stepping loop controls - if ((mytime + dt) >= finaltime) dt = finaltime - mytime + if ((mytime + dt) >= finaltime) dt = finaltime - mytime t_step = t_step + 1 end subroutine s_perform_time_step @@ -923,8 +923,8 @@ contains integer, intent(INOUT) :: t_step real(kind(0d0)), intent(INOUT) :: time_avg, time_final real(kind(0d0)), intent(INOUT) :: io_time_avg, io_time_final - real(kind(0d0)), dimension(:), intent(INOUT) :: proc_time - real(kind(0d0)), dimension(:), intent(INOUT) :: io_proc_time + real(kind(0d0)), dimension(:), intent(INOUT) :: proc_time + real(kind(0d0)), dimension(:), intent(INOUT) :: io_proc_time logical, intent(INOUT) :: file_exists real(kind(0d0)), intent(INOUT) :: start, finish integer, intent(INOUT) :: nt @@ -976,7 +976,7 @@ contains end subroutine s_save_performance_metrics subroutine s_save_data(t_step, start, finish, io_time_avg, nt) - real(kind(0d0)), intent(INOUT) :: start, finish, io_time_avg + real(kind(0d0)), intent(INOUT) :: start, finish, io_time_avg integer, intent(INOUT) :: t_step, nt integer :: i, j, k, l @@ -989,8 +989,8 @@ contains do l = 0, p do k = 0, n do j = 0, m - if(ieee_is_nan(q_cons_ts(1)%vf(i)%sf(j, k, l))) then - print *, "NaN(s) in timestep output.", j, k, l, i, proc_rank, t_step, m, n, p + if (ieee_is_nan(q_cons_ts(1)%vf(i)%sf(j, k, l))) then + print *, "NaN(s) in timestep output.", j, k, l, i, proc_rank, t_step, m, n, p error stop "NaN(s) in timestep output." end if end do @@ -998,7 +998,7 @@ contains end do end do - if(qbmm .and. .not. polytropic) then + if (qbmm .and. .not. polytropic) then !$acc update host(pb_ts(1)%sf) !$acc update host(mv_ts(1)%sf) end if @@ -1014,23 +1014,23 @@ contains end if end if - end subroutine s_save_data + end subroutine s_save_data subroutine s_initialize_modules() call s_initialize_global_parameters_module() !Quadrature weights and nodes for polydisperse simulations - if(bubbles .and. nb > 1 .and. R0_type == 1) then + if (bubbles .and. nb > 1 .and. R0_type == 1) then call s_simpson end if !Initialize variables for non-polytropic (Preston) model - if(bubbles .and. .not. polytropic) then + if (bubbles .and. .not. polytropic) then call s_initialize_nonpoly() end if !Initialize pb based on surface tension for qbmm (polytropic) - if(qbmm .and. polytropic .and. Web /= dflt_real) then - pb0 = pref + 2d0 * fluid_pp(1)%ss / (R0*R0ref) - pb0 = pb0 / pref - pref = 1d0 + if (qbmm .and. polytropic .and. Web /= dflt_real) then + pb0 = pref + 2d0*fluid_pp(1)%ss/(R0*R0ref) + pb0 = pb0/pref + pref = 1d0 end if #if defined(MFC_OpenACC) && defined(MFC_MEMORY_DUMP) @@ -1042,7 +1042,7 @@ contains if (grid_geometry == 3) call s_initialize_fftw_module() call s_initialize_riemann_solvers_module() - if(bubbles) call s_initialize_bubbles_module() + if (bubbles) call s_initialize_bubbles_module() if (qbmm) call s_initialize_qbmm_module() @@ -1116,11 +1116,11 @@ contains integer(acc_device_kind) :: devtype #endif - ! Initializing MPI execution environment + ! Initializing MPI execution environment call s_mpi_initialize() - ! Bind GPUs if OpenACC is enabled + ! Bind GPUs if OpenACC is enabled #ifdef MFC_OpenACC #ifndef MFC_MPI local_size = 1 @@ -1133,8 +1133,8 @@ contains #endif devtype = acc_get_device_type() - devNum = acc_get_num_devices(devtype) - dev = mod(local_rank, devNum) + devNum = acc_get_num_devices(devtype) + dev = mod(local_rank, devNum) call acc_set_device_num(dev, devtype) #endif @@ -1168,22 +1168,21 @@ contains !$acc update device(m, n, p) !$acc update device(momxb, momxe, bubxb, bubxe, advxb, advxe, contxb, contxe, strxb, strxe) do i = 1, sys_size - !$acc update device(q_cons_ts(1)%vf(i)%sf) + !$acc update device(q_cons_ts(1)%vf(i)%sf) end do - if(qbmm .and. .not. polytropic) then - !$acc update device(pb_ts(1)%sf, mv_ts(1)%sf) + if (qbmm .and. .not. polytropic) then + !$acc update device(pb_ts(1)%sf, mv_ts(1)%sf) end if !$acc update device(dt, sys_size, pref, rhoref, gamma_idx, pi_inf_idx, E_idx, alf_idx, stress_idx, mpp_lim, bubbles, hypoelasticity, alt_soundspeed, avg_state, num_fluids, model_eqns, num_dims, mixture_err, nb, weight, grid_geometry, cyl_coord, mapped_weno, mp_weno, weno_eps) !$acc update device(nb, R0ref, Ca, Web, Re_inv, weight, R0, V0, bubbles, polytropic, polydisperse, qbmm, R0_type, ptil, bubble_model, thermal, poly_sigma) !$acc update device(R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, pv, M_n, M_v, k_n, k_v, pb0, mass_n0, mass_v0, Pe_T, Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN , mul0, ss, gamma_v, mu_v, gamma_m, gamma_n, mu_n, gam) !$acc update device(monopole, num_mono) !$acc update device(relax) - if(relax) then - !$acc update device(palpha_eps, ptgalpha_eps) + if (relax) then + !$acc update device(palpha_eps, ptgalpha_eps) end if end subroutine s_initialize_gpu_vars - subroutine s_finalize_modules() ! Disassociate pointers for serial and parallel I/O s_read_data_files => null() @@ -1200,7 +1199,7 @@ contains if (grid_geometry == 3) call s_finalize_fftw_module call s_finalize_mpi_proxy_module() call s_finalize_global_parameters_module() - if (relax) call s_finalize_relaxation_solver_module() + if (relax) call s_finalize_relaxation_solver_module() if (any(Re_size > 0)) then call s_finalize_viscous_module() diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 679ed254c..fc1e1065f 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -51,7 +51,7 @@ module m_time_steppers integer, private :: num_ts !< !! Number of time stages in the time-stepping scheme -!$acc declare create(q_cons_ts,q_prim_vf,rhs_vf,q_prim_ts, rhs_mv, rhs_pb) + !$acc declare create(q_cons_ts,q_prim_vf,rhs_vf,q_prim_ts, rhs_mv, rhs_pb) contains @@ -91,7 +91,6 @@ contains ! Allocating the cell-average conservative variables @:ALLOCATE(q_cons_ts(1:num_ts)) - do i = 1, num_ts @:ALLOCATE(q_cons_ts(i)%vf(1:sys_size)) end do @@ -99,8 +98,8 @@ contains do i = 1, num_ts do j = 1, sys_size @:ALLOCATE(q_cons_ts(i)%vf(j)%sf(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end)) + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end)) end do end do @@ -115,91 +114,91 @@ contains do i = 0, 3 do j = 1, sys_size @:ALLOCATE(q_prim_ts(i)%vf(j)%sf(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end)) + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end)) end do end do end if ! 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_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end)) + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end)) end do if (bubbles) then do i = bub_idx%beg, bub_idx%end @:ALLOCATE(q_prim_vf(i)%sf(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end)) + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end)) end do end if @:ALLOCATE(pb_ts(1:2)) !Initialize bubble variables pb and mv at all quadrature nodes for all R0 bins - if(qbmm .and. (.not. polytropic)) then + if (qbmm .and. (.not. polytropic)) then @:ALLOCATE(pb_ts(1)%sf(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end, 1:nnode, 1:nb)) + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end, 1:nnode, 1:nb)) @:ALLOCATE(pb_ts(2)%sf(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end, 1:nnode, 1:nb)) + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end, 1:nnode, 1:nb)) @:ALLOCATE(rhs_pb(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end, 1:nnode, 1:nb)) - else if(qbmm .and. polytropic) then + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end, 1:nnode, 1:nb)) + else if (qbmm .and. polytropic) then @:ALLOCATE(pb_ts(1)%sf(ix_t%beg:ix_t%beg + 1, & - iy_t%beg:iy_t%beg + 1, & - iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) + iy_t%beg:iy_t%beg + 1, & + iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) @:ALLOCATE(pb_ts(2)%sf(ix_t%beg:ix_t%beg + 1, & - iy_t%beg:iy_t%beg + 1, & - iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) + iy_t%beg:iy_t%beg + 1, & + iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) @:ALLOCATE(rhs_pb(ix_t%beg:ix_t%beg + 1, & - iy_t%beg:iy_t%beg + 1, & - iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) + iy_t%beg:iy_t%beg + 1, & + iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) end if @:ALLOCATE(mv_ts(1:2)) - if(qbmm .and. (.not. polytropic)) then + if (qbmm .and. (.not. polytropic)) then @:ALLOCATE(mv_ts(1)%sf(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end, 1:nnode, 1:nb)) + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end, 1:nnode, 1:nb)) @:ALLOCATE(mv_ts(2)%sf(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end, 1:nnode, 1:nb)) + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end, 1:nnode, 1:nb)) @:ALLOCATE(rhs_mv(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end, 1:nnode, 1:nb)) - else if(qbmm .and. polytropic) then + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end, 1:nnode, 1:nb)) + else if (qbmm .and. polytropic) then @:ALLOCATE(mv_ts(1)%sf(ix_t%beg:ix_t%beg + 1, & - iy_t%beg:iy_t%beg + 1, & - iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) + iy_t%beg:iy_t%beg + 1, & + iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) @:ALLOCATE(mv_ts(2)%sf(ix_t%beg:ix_t%beg + 1, & - iy_t%beg:iy_t%beg + 1, & - iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) + iy_t%beg:iy_t%beg + 1, & + iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) @:ALLOCATE(rhs_mv(ix_t%beg:ix_t%beg + 1, & - iy_t%beg:iy_t%beg + 1, & - iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) + iy_t%beg:iy_t%beg + 1, & + iz_t%beg:iz_t%beg + 1, 1:nnode, 1:nb)) end if if (hypoelasticity) then do i = stress_idx%beg, stress_idx%end @:ALLOCATE(q_prim_vf(i)%sf(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end)) + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end)) end do end if if (model_eqns == 3) then do i = internalEnergies_idx%beg, internalEnergies_idx%end @:ALLOCATE(q_prim_vf(i)%sf(ix_t%beg:ix_t%end, & - iy_t%beg:iy_t%end, & - iz_t%beg:iz_t%end)) + iy_t%beg:iy_t%end, & + iz_t%beg:iz_t%end)) end do end if @@ -253,7 +252,7 @@ contains if (t_step == t_step_stop) return -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, sys_size do l = 0, p do k = 0, n @@ -266,15 +265,15 @@ contains end do end do !Evolve pb and mv for non-polytropic qbmm - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n do j = 0, m do q = 1, nnode pb_ts(1)%sf(j, k, l, q, i) = & - pb_ts(1)%sf(j, k, l, q, i) & + pb_ts(1)%sf(j, k, l, q, i) & + dt*rhs_pb(j, k, l, q, i) end do end do @@ -283,22 +282,22 @@ contains end do end if - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n do j = 0, m do q = 1, nnode mv_ts(1)%sf(j, k, l, q, i) = & - mv_ts(1)%sf(j, k, l, q, i) & + mv_ts(1)%sf(j, k, l, q, i) & + dt*rhs_mv(j, k, l, q, i) end do end do end do end do end do - end if + end if if (grid_geometry == 3) call s_apply_fourier_filter(q_cons_ts(1)%vf) @@ -346,7 +345,7 @@ contains if (t_step == t_step_stop) return -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, sys_size do l = 0, p do k = 0, n @@ -359,15 +358,15 @@ contains end do end do !Evolve pb and mv for non-polytropic qbmm - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n do j = 0, m do q = 1, nnode pb_ts(2)%sf(j, k, l, q, i) = & - pb_ts(1)%sf(j, k, l, q, i) & + pb_ts(1)%sf(j, k, l, q, i) & + dt*rhs_pb(j, k, l, q, i) end do end do @@ -376,15 +375,15 @@ contains end do end if - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n do j = 0, m do q = 1, nnode mv_ts(2)%sf(j, k, l, q, i) = & - mv_ts(1)%sf(j, k, l, q, i) & + mv_ts(1)%sf(j, k, l, q, i) & + dt*rhs_mv(j, k, l, q, i) end do end do @@ -395,16 +394,16 @@ contains if (grid_geometry == 3) call s_apply_fourier_filter(q_cons_ts(2)%vf) - if ( model_eqns == 3 .and. (.not.relax ) ) then + if (model_eqns == 3 .and. (.not. relax)) then call s_pressure_relaxation_procedure(q_cons_ts(2)%vf) end if ! ================================================================== ! Stage 2 of 2 ===================================================== - call s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, pb_ts(2)%sf, rhs_pb, mv_ts(2)%sf, rhs_mv,t_step) + call s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, pb_ts(2)%sf, rhs_pb, mv_ts(2)%sf, rhs_mv, t_step) -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, sys_size do l = 0, p do k = 0, n @@ -418,8 +417,8 @@ contains end do end do - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n @@ -427,8 +426,8 @@ contains do q = 1, nnode pb_ts(1)%sf(j, k, l, q, i) = & (pb_ts(1)%sf(j, k, l, q, i) & - + pb_ts(2)%sf(j, k, l, q, i) & - + dt*rhs_pb(j, k, l, q, i))/2d0 + + pb_ts(2)%sf(j, k, l, q, i) & + + dt*rhs_pb(j, k, l, q, i))/2d0 end do end do end do @@ -436,8 +435,8 @@ contains end do end if - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n @@ -445,8 +444,8 @@ contains do q = 1, nnode mv_ts(1)%sf(j, k, l, q, i) = & (mv_ts(1)%sf(j, k, l, q, i) & - + mv_ts(2)%sf(j, k, l, q, i) & - + dt*rhs_mv(j, k, l, q, i))/2d0 + + mv_ts(2)%sf(j, k, l, q, i) & + + dt*rhs_mv(j, k, l, q, i))/2d0 end do end do end do @@ -456,7 +455,7 @@ contains if (grid_geometry == 3) call s_apply_fourier_filter(q_cons_ts(1)%vf) - if ( model_eqns == 3 .and. (.not.relax ) ) then + if (model_eqns == 3 .and. (.not. relax)) then call s_pressure_relaxation_procedure(q_cons_ts(1)%vf) end if @@ -481,7 +480,7 @@ contains integer, intent(IN) :: t_step real(kind(0d0)), intent(INOUT) :: time_avg - integer :: i, j, k, l, q + integer :: i, j, k, l, q real(kind(0d0)) :: ts_error, denom, error_fraction, time_step_factor !< Generic loop iterator real(kind(0d0)) :: start, finish @@ -503,7 +502,7 @@ contains if (t_step == t_step_stop) return -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, sys_size do l = 0, p do k = 0, n @@ -516,8 +515,8 @@ contains end do end do !Evolve pb and mv for non-polytropic qbmm - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n @@ -533,8 +532,8 @@ contains end do end if - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n @@ -552,7 +551,7 @@ contains if (grid_geometry == 3) call s_apply_fourier_filter(q_cons_ts(2)%vf) - if ( model_eqns == 3 .and. (.not.relax ) ) then + if (model_eqns == 3 .and. (.not. relax)) then call s_pressure_relaxation_procedure(q_cons_ts(2)%vf) end if @@ -562,7 +561,7 @@ contains call s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, pb_ts(2)%sf, rhs_pb, mv_ts(2)%sf, rhs_mv, t_step) -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, sys_size do l = 0, p do k = 0, n @@ -576,8 +575,8 @@ contains end do end do - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n @@ -585,8 +584,8 @@ contains do q = 1, nnode pb_ts(2)%sf(j, k, l, q, i) = & (3d0*pb_ts(1)%sf(j, k, l, q, i) & - + pb_ts(2)%sf(j, k, l, q, i) & - + dt*rhs_pb(j, k, l, q, i))/4d0 + + pb_ts(2)%sf(j, k, l, q, i) & + + dt*rhs_pb(j, k, l, q, i))/4d0 end do end do end do @@ -594,8 +593,8 @@ contains end do end if - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n @@ -603,8 +602,8 @@ contains do q = 1, nnode mv_ts(2)%sf(j, k, l, q, i) = & (3d0*mv_ts(1)%sf(j, k, l, q, i) & - + mv_ts(2)%sf(j, k, l, q, i) & - + dt*rhs_mv(j, k, l, q, i))/4d0 + + mv_ts(2)%sf(j, k, l, q, i) & + + dt*rhs_mv(j, k, l, q, i))/4d0 end do end do end do @@ -613,7 +612,7 @@ contains end if if (grid_geometry == 3) call s_apply_fourier_filter(q_cons_ts(2)%vf) - if ( model_eqns == 3 .and. (.not.relax ) ) then + if (model_eqns == 3 .and. (.not. relax)) then call s_pressure_relaxation_procedure(q_cons_ts(2)%vf) end if @@ -622,7 +621,7 @@ contains ! Stage 3 of 3 ===================================================== call s_compute_rhs(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, pb_ts(2)%sf, rhs_pb, mv_ts(2)%sf, rhs_mv, t_step) -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do i = 1, sys_size do l = 0, p do k = 0, n @@ -636,8 +635,8 @@ contains end do end do - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n @@ -645,8 +644,8 @@ contains do q = 1, nnode pb_ts(1)%sf(j, k, l, q, i) = & (pb_ts(1)%sf(j, k, l, q, i) & - + 2d0*pb_ts(2)%sf(j, k, l, q, i) & - + 2d0*dt*rhs_pb(j, k, l, q, i))/3d0 + + 2d0*pb_ts(2)%sf(j, k, l, q, i) & + + 2d0*dt*rhs_pb(j, k, l, q, i))/3d0 end do end do end do @@ -654,8 +653,8 @@ contains end do end if - if(qbmm .and. (.not. polytropic)) then -!$acc parallel loop collapse(5) gang vector default(present) + if (qbmm .and. (.not. polytropic)) then + !$acc parallel loop collapse(5) gang vector default(present) do i = 1, nb do l = 0, p do k = 0, n @@ -663,8 +662,8 @@ contains do q = 1, nnode mv_ts(1)%sf(j, k, l, q, i) = & (mv_ts(1)%sf(j, k, l, q, i) & - + 2d0*mv_ts(2)%sf(j, k, l, q, i) & - + 2d0*dt*rhs_mv(j, k, l, q, i))/3d0 + + 2d0*mv_ts(2)%sf(j, k, l, q, i) & + + 2d0*dt*rhs_mv(j, k, l, q, i))/3d0 end do end do end do @@ -674,7 +673,7 @@ contains if (grid_geometry == 3) call s_apply_fourier_filter(q_cons_ts(1)%vf) - if ( model_eqns == 3 .and. (.not.relax ) ) then + if (model_eqns == 3 .and. (.not. relax)) then call s_pressure_relaxation_procedure(q_cons_ts(1)%vf) end if @@ -704,7 +703,7 @@ contains integer :: i !< Generic loop iterator do i = 1, sys_size -!$acc update host(q_prim_vf(i)%sf) + !$acc update host(q_prim_vf(i)%sf) end do if (t_step == t_step_start) then diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 9a094cc17..a60350de3 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -16,21 +16,20 @@ module m_viscous use m_helper ! ========================================================================== - private; public s_get_viscous, & - s_compute_viscous_stress_tensor, & - s_initialize_viscous_module, & - s_reconstruct_cell_boundary_values_visc_deriv, & - s_finalize_viscous_module + private; public s_get_viscous, & + s_compute_viscous_stress_tensor, & + s_initialize_viscous_module, & + s_reconstruct_cell_boundary_values_visc_deriv, & + s_finalize_viscous_module type(int_bounds_info) :: iv type(int_bounds_info) :: is1, is2, is3 - !$acc declare create(is1, is2, is3, iv) + !$acc declare create(is1, is2, is3, iv) real(kind(0d0)), allocatable, dimension(:, :) :: Res -!$acc declare create(Res) + !$acc declare create(Res) - - contains +contains subroutine s_initialize_viscous_module() integer :: i, j !< generic loop iterators @@ -42,8 +41,7 @@ module m_viscous Res(i, j) = fluid_pp(Re_idx(i, j))%Re(i) end do end do -!$acc update device(Res, Re_idx, Re_size) - + !$acc update device(Res, Re_idx, Re_size) end subroutine s_initialize_viscous_module @@ -75,13 +73,13 @@ module m_viscous type(int_bounds_info) :: ix, iy, iz - !$acc update device(ix, iy, iz) + !$acc update device(ix, iy, iz) - !$acc parallel loop collapse(3) gang vector default(present) + !$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 + !$acc loop seq do i = momxb, E_idx tau_Re_vf(i)%sf(j, k, l) = 0d0 end do @@ -89,17 +87,17 @@ module m_viscous 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 ) + !$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 + !$acc loop seq do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) if (bubbles .and. num_fluids == 1) then alpha_visc(i) = 1d0 - q_prim_vf(E_idx + i)%sf(j, k, l) - else + else alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) end if end do @@ -110,14 +108,14 @@ module m_viscous pi_inf_visc = 0d0 if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then - !$acc loop seq + !$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 + !$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) @@ -136,7 +134,7 @@ module m_viscous 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) @@ -147,7 +145,7 @@ module m_viscous end if - !$acc loop seq + !$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) @@ -155,15 +153,15 @@ module m_viscous end do if (any(Re_size > 0)) then - !$acc loop seq + !$acc loop seq do i = 1, 2 Re_visc(i) = dflt_real if (Re_size(i) > 0) Re_visc(i) = 0d0 - !$acc loop seq + !$acc loop seq do q = 1, Re_size(i) Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & - + Re_visc(i) + + Re_visc(i) end do Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) @@ -174,18 +172,18 @@ module m_viscous tau_Re(2, 1) = (grad_y_vf(1)%sf(j, k, l) + & grad_x_vf(2)%sf(j, k, l))/ & - Re_visc(1) - + 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 + (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) @@ -196,17 +194,17 @@ module m_viscous 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 ) + !$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 + !$acc loop seq do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) if (bubbles .and. num_fluids == 1) then alpha_visc(i) = 1d0 - q_prim_vf(E_idx + i)%sf(j, k, l) - else + else alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) end if end do @@ -217,14 +215,14 @@ module m_viscous pi_inf_visc = 0d0 if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then - !$acc loop seq + !$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 + !$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) @@ -243,7 +241,7 @@ module m_viscous 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) @@ -254,7 +252,7 @@ module m_viscous end if - !$acc loop seq + !$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) @@ -262,15 +260,15 @@ module m_viscous end do if (any(Re_size > 0)) then - !$acc loop seq + !$acc loop seq do i = 1, 2 Re_visc(i) = dflt_real if (Re_size(i) > 0) Re_visc(i) = 0d0 - !$acc loop seq + !$acc loop seq do q = 1, Re_size(i) Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & - + Re_visc(i) + + Re_visc(i) end do Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) @@ -282,7 +280,7 @@ module m_viscous 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) + Re_visc(2) tau_Re_vf(momxb + 1)%sf(j, k, l) = & tau_Re_vf(momxb + 1)%sf(j, k, l) - & @@ -300,17 +298,17 @@ module m_viscous 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 ) + !$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 + !$acc loop seq do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) if (bubbles .and. num_fluids == 1) then alpha_visc(i) = 1d0 - q_prim_vf(E_idx + i)%sf(j, k, l) - else + else alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) end if end do @@ -321,14 +319,14 @@ module m_viscous pi_inf_visc = 0d0 if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then - !$acc loop seq + !$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 + !$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) @@ -347,7 +345,7 @@ module m_viscous 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) @@ -358,7 +356,7 @@ module m_viscous end if - !$acc loop seq + !$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) @@ -366,15 +364,15 @@ module m_viscous end do if (any(Re_size > 0)) then - !$acc loop seq + !$acc loop seq do i = 1, 2 Re_visc(i) = dflt_real if (Re_size(i) > 0) Re_visc(i) = 0d0 - !$acc loop seq + !$acc loop seq do q = 1, Re_size(i) Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & - + Re_visc(i) + + Re_visc(i) end do Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) @@ -384,14 +382,14 @@ module m_viscous end if tau_Re(2, 2) = -(2d0/3d0)*grad_z_vf(3)%sf(j, k, l)/y_cc(k)/ & - Re_visc(1) + Re_visc(1) tau_Re(2, 3) = ((grad_z_vf(2)%sf(j, k, l) - & - q_prim_vf(momxe)%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) + Re_visc(1) - !$acc loop seq + !$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) - & @@ -408,17 +406,17 @@ module m_viscous 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 ) + !$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 + !$acc loop seq do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) if (bubbles .and. num_fluids == 1) then alpha_visc(i) = 1d0 - q_prim_vf(E_idx + i)%sf(j, k, l) - else + else alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) end if end do @@ -429,14 +427,14 @@ module m_viscous pi_inf_visc = 0d0 if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then - !$acc loop seq + !$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 + !$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) @@ -455,7 +453,7 @@ module m_viscous 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) @@ -466,7 +464,7 @@ module m_viscous end if - !$acc loop seq + !$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) @@ -474,15 +472,15 @@ module m_viscous end do if (any(Re_size > 0)) then - !$acc loop seq + !$acc loop seq do i = 1, 2 Re_visc(i) = dflt_real if (Re_size(i) > 0) Re_visc(i) = 0d0 - !$acc loop seq + !$acc loop seq do q = 1, Re_size(i) Re_visc(i) = alpha_visc(Re_idx(i, q))/Res(i, q) & - + Re_visc(i) + + Re_visc(i) end do Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) @@ -492,7 +490,7 @@ module m_viscous end if tau_Re(2, 2) = grad_z_vf(3)%sf(j, k, l)/y_cc(k)/ & - Re_visc(2) + Re_visc(2) tau_Re_vf(momxb + 1)%sf(j, k, l) = & tau_Re_vf(momxb + 1)%sf(j, k, l) - & @@ -514,18 +512,18 @@ module m_viscous !! @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, & + 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, & + dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_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 + 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(1:num_dims) :: qL_prim, qR_prim @@ -586,30 +584,30 @@ module m_viscous iv%beg = mom_idx%beg; iv%end = mom_idx%end !$acc update device(iv) - !$acc parallel loop collapse(3) gang vector default(present) + !$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 + !$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))/ & + 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) + !$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 + !$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))/ & + q_prim_qp%vf(i)%sf(j, k, l))/ & (x_cc(j + 1) - x_cc(j)) end do end do @@ -618,22 +616,22 @@ module m_viscous if (n > 0) then - !$acc parallel loop collapse(3) gang vector default(present) + !$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 + !$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))/ & + 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) + !$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 @@ -641,86 +639,86 @@ module m_viscous 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))/ & + 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) + !$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 + !$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)) + 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) + 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) + !$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 + !$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(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) + 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) + !$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 + !$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)) + 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) + 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) + !$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 + !$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(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) + dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) end do end do @@ -729,81 +727,81 @@ module m_viscous if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) + !$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 + !$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))/ & + 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) + !$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 + !$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))/ & + 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) + !$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 + !$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)) + 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) + 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) + !$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 + !$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(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) + 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) + !$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 @@ -812,19 +810,19 @@ module m_viscous 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)) + 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) + 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) + !$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 @@ -833,95 +831,95 @@ module m_viscous 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(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) + 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) + !$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 + !$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)) + 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) + 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) + !$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 + !$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(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) + 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) + !$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 + !$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)) + 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) + 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) + !$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 + !$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(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) + dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) end do end do @@ -930,20 +928,20 @@ module m_viscous 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), & - ix, iy, iz, buff_size) + dq_prim_dx_qp%vf(i), & + dq_prim_dy_qp%vf(i), & + dq_prim_dz_qp%vf(i), & + ix, iy, iz, buff_size) 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), & - ix, iy, iz, buff_size) + dq_prim_dx_qp%vf(i), & + dq_prim_dy_qp%vf(i), & + dq_prim_dy_qp%vf(i), & + ix, iy, iz, buff_size) end do end if @@ -951,10 +949,10 @@ module m_viscous 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), & - ix, iy, iz, buff_size) + dq_prim_dx_qp%vf(i), & + dq_prim_dx_qp%vf(i), & + dq_prim_dx_qp%vf(i), & + ix, iy, iz, buff_size) end do end if @@ -969,7 +967,7 @@ module m_viscous 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 + 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 @@ -1003,27 +1001,27 @@ module m_viscous 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) + 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) + 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) + 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) + !$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 @@ -1035,7 +1033,7 @@ module m_viscous end do end do elseif (norm_dir == 3) then -!$acc parallel loop collapse(4) gang vector default(present) + !$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 @@ -1047,7 +1045,7 @@ module m_viscous end do end do elseif (norm_dir == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + !$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 @@ -1074,7 +1072,7 @@ module m_viscous type(int_bounds_info) :: ix, iy, iz - real(kind(0d0)), dimension(startx:, starty:, startz:, iv%beg:), intent(INOUT) :: vL_x, vL_y, vL_z, vR_x, vR_y, vR_z + 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 @@ -1106,27 +1104,27 @@ module m_viscous 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) + 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) + 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) + 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) + !$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 @@ -1136,9 +1134,9 @@ module m_viscous end do end do end do - end do + end do elseif (norm_dir == 3) then -!$acc parallel loop collapse(4) gang vector default(present) + !$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 @@ -1150,7 +1148,7 @@ module m_viscous end do end do elseif (norm_dir == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + !$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 @@ -1168,7 +1166,7 @@ module m_viscous end subroutine s_reconstruct_cell_boundary_values_visc_deriv ! -------------------- - !> The purpose of this subroutine is to employ the inputted + !> 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 @@ -1184,7 +1182,7 @@ module m_viscous dL, dim, buff_size_in) type(int_bounds_info) :: ix, iy, iz, iv - + integer :: buff_size_in, dim real(kind(0d0)), dimension(-buff_size_in:dim + buff_size_in) :: dL @@ -1213,18 +1211,18 @@ module m_viscous ! cell-boundaries, to calculate the cell-averaged first-order ! spatial derivatives inside the cell. -!$acc parallel loop collapse(3) gang vector default(present) + !$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 + !$acc loop seq do i = iv%beg, iv%end - dv_ds_vf(i)%sf(j,k,l) = & - 1d0/((1d0+wa_flg)*dL(j)) & - *( wa_flg*vL_vf(i)%sf(j+1,k,l) & - + vR_vf(i)%sf( j ,k,l) & - - vL_vf(i)%sf( j ,k,l) & - - wa_flg*vR_vf(i)%sf(j-1,k,l) ) + dv_ds_vf(i)%sf(j, k, l) = & + 1d0/((1d0 + wa_flg)*dL(j)) & + *(wa_flg*vL_vf(i)%sf(j + 1, k, l) & + + vR_vf(i)%sf(j, k, l) & + - vL_vf(i)%sf(j, k, l) & + - wa_flg*vR_vf(i)%sf(j - 1, k, l)) end do end do end do @@ -1241,19 +1239,18 @@ module m_viscous ! cell-boundaries, to calculate the cell-averaged first-order ! spatial derivatives inside the cell. -!$acc parallel loop collapse(3) gang vector default(present) - + !$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 + !$acc loop seq do i = iv%beg, iv%end - dv_ds_vf(i)%sf(j,k,l) = & - 1d0/((1d0+wa_flg)*dL(k)) & - *( wa_flg*vL_vf(i)%sf(j,k+1,l) & - + vR_vf(i)%sf(j, k ,l) & - - vL_vf(i)%sf(j, k ,l) & - - wa_flg*vR_vf(i)%sf(j,k-1,l) ) + dv_ds_vf(i)%sf(j, k, l) = & + 1d0/((1d0 + wa_flg)*dL(k)) & + *(wa_flg*vL_vf(i)%sf(j, k + 1, l) & + + vR_vf(i)%sf(j, k, l) & + - vL_vf(i)%sf(j, k, l) & + - wa_flg*vR_vf(i)%sf(j, k - 1, l)) end do end do end do @@ -1270,18 +1267,18 @@ module m_viscous ! cell-boundaries, to calculate the cell-averaged first-order ! spatial derivatives inside the cell. -!$acc parallel loop collapse(3) gang vector default(present) + !$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 + !$acc loop seq do i = iv%beg, iv%end - dv_ds_vf(i)%sf(j,k,l) = & - 1d0/((1d0+wa_flg)*dL(l)) & - *( wa_flg*vL_vf(i)%sf(j,k,l+1) & - + vR_vf(i)%sf(j,k, l ) & - - vL_vf(i)%sf(j,k, l ) & - - wa_flg*vR_vf(i)%sf(j,k,l-1) ) + dv_ds_vf(i)%sf(j, k, l) = & + 1d0/((1d0 + wa_flg)*dL(l)) & + *(wa_flg*vL_vf(i)%sf(j, k, l + 1) & + + vR_vf(i)%sf(j, k, l) & + - vL_vf(i)%sf(j, k, l) & + - wa_flg*vR_vf(i)%sf(j, k, l - 1)) end do end do end do @@ -1327,7 +1324,7 @@ module m_viscous !$acc update device(ix, iy, iz) - !$acc parallel loop collapse(3) gang vector default(present) + !$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 @@ -1339,7 +1336,7 @@ module m_viscous end do if (n > 0) then - !$acc parallel loop collapse(3) gang vector + !$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 @@ -1352,7 +1349,7 @@ module m_viscous end if if (p > 0) then - !$acc parallel loop collapse(3) gang vector + !$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 @@ -1379,7 +1376,7 @@ module m_viscous !$acc update device(ix, iy, iz) - !$acc parallel loop collapse(2) gang vector default(present) + !$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) = & @@ -1391,7 +1388,7 @@ module m_viscous end do end do if (n > 0) then - !$acc parallel loop collapse(2) gang vector default(present) + !$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) = & @@ -1403,7 +1400,7 @@ module m_viscous end do end do if (p > 0) then - !$acc parallel loop collapse(2) gang vector default(present) + !$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) = & @@ -1418,45 +1415,45 @@ module m_viscous end if if (bc_x%beg <= -3) then - !$acc parallel loop collapse(2) gang vector default(present) + !$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)) + (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) + !$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)) + (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 /= -14) then - !$acc parallel loop collapse(2) gang vector default(present) + !$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)) + (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) + !$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)) + (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) + !$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) = & @@ -1466,7 +1463,7 @@ module m_viscous end do end if if (bc_z%end <= -3) then - !$acc parallel loop collapse(2) gang vector default(present) + !$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) = & @@ -1484,4 +1481,4 @@ module m_viscous @:DEALLOCATE(Res) end subroutine s_finalize_viscous_module -end module m_viscous \ No newline at end of file +end module m_viscous diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 940a2fac4..f1facc15e 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -3,7 +3,6 @@ !! @brief Contains module m_weno #:include 'macros.fpp' - !> @brief Weighted essentially non-oscillatory (WENO) reconstruction scheme !! that is supplemented with monotonicity preserving bounds (MPWENO) !! and a mapping function that boosts the accuracy of the non-linear @@ -40,12 +39,9 @@ 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. !> @{ - real(kind(0d0)), 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 !> @} - - - ! WENO Coefficients ======================================================== !> @name Polynomial coefficients at the left and right cell-boundaries (CB) and at @@ -110,12 +106,12 @@ module m_weno real(kind(0d0)) :: test -!$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, & -!$acc v_size, is1, is2, is3, test) + !$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, & + !$acc v_size, is1, is2, is3, test) contains @@ -146,20 +142,20 @@ contains is3%end = p - is3%beg @:ALLOCATE(poly_coef_cbL_x(is1%beg + weno_polyn:is1%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) + 0:weno_polyn - 1)) @:ALLOCATE(poly_coef_cbR_x(is1%beg + weno_polyn:is1%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) + 0:weno_polyn - 1)) @:ALLOCATE(d_cbL_x(0:weno_polyn, is1%beg + weno_polyn:is1%end - weno_polyn)) @:ALLOCATE(d_cbR_x(0:weno_polyn, is1%beg + weno_polyn:is1%end - weno_polyn)) @:ALLOCATE(beta_coef_x(is1%beg + weno_polyn:is1%end - weno_polyn, 0:weno_polyn, & - 0:2*(weno_polyn - 1))) + 0:2*(weno_polyn - 1))) call s_compute_weno_coefficients(1, is1) @:ALLOCATE(v_rs_ws_x(is1%beg:is1%end, & - is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) ! ================================================================== @@ -178,20 +174,20 @@ contains is3%end = p - is3%beg @:ALLOCATE(poly_coef_cbL_y(is2%beg + weno_polyn:is2%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) + 0:weno_polyn - 1)) @:ALLOCATE(poly_coef_cbR_y(is2%beg + weno_polyn:is2%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) + 0:weno_polyn - 1)) @:ALLOCATE(d_cbL_y(0:weno_polyn, is2%beg + weno_polyn:is2%end - weno_polyn)) @:ALLOCATE(d_cbR_y(0:weno_polyn, is2%beg + weno_polyn:is2%end - weno_polyn)) @:ALLOCATE(beta_coef_y(is2%beg + weno_polyn:is2%end - weno_polyn, 0:weno_polyn, & - 0:2*(weno_polyn - 1))) + 0:2*(weno_polyn - 1))) call s_compute_weno_coefficients(2, is2) @:ALLOCATE(v_rs_ws_y(is2%beg:is2%end, & - is1%beg:is1%end, is3%beg:is3%end, 1:sys_size)) + is1%beg:is1%end, is3%beg:is3%end, 1:sys_size)) ! ================================================================== @@ -203,20 +199,20 @@ contains is3%beg = -buff_size; is3%end = p - is3%beg @:ALLOCATE(poly_coef_cbL_z(is3%beg + weno_polyn:is3%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) + 0:weno_polyn - 1)) @:ALLOCATE(poly_coef_cbR_z(is3%beg + weno_polyn:is3%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) + 0:weno_polyn - 1)) @:ALLOCATE(d_cbL_z(0:weno_polyn, is3%beg + weno_polyn:is3%end - weno_polyn)) @:ALLOCATE(d_cbR_z(0:weno_polyn, is3%beg + weno_polyn:is3%end - weno_polyn)) @:ALLOCATE(beta_coef_z(is3%beg + weno_polyn:is3%end - weno_polyn, 0:weno_polyn, & - 0:2*(weno_polyn - 1))) + 0:2*(weno_polyn - 1))) call s_compute_weno_coefficients(3, is3) @:ALLOCATE(v_rs_ws_z(is3%beg:is3%end, & - is2%beg:is2%end, is1%beg:is1%end, 1:sys_size)) + is2%beg:is2%end, is1%beg:is1%end, 1:sys_size)) ! ================================================================== @@ -365,66 +361,66 @@ contains beta_coef_${XYZ}$ (i + 1, 0, 0) = & 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(10d0*(s_cb(i + 1) - & s_cb(i))**2d0 + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - & - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2d0)/((s_cb(i) - & - s_cb(i + 3))**2d0*(s_cb(i + 1) - s_cb(i + 3))**2d0) + s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2d0)/((s_cb(i) - & + s_cb(i + 3))**2d0*(s_cb(i + 1) - s_cb(i + 3))**2d0) beta_coef_${XYZ}$ (i + 1, 0, 1) = & 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(19d0*(s_cb(i + 1) - & s_cb(i))**2d0 - (s_cb(i + 1) - s_cb(i))*(s_cb(i + 3) - & - s_cb(i + 1)) + 2d0*(s_cb(i + 2) - s_cb(i))*((s_cb(i + 2) - & - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))))/((s_cb(i) - & - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3))**2d0*(s_cb(i + 3) - & - s_cb(i + 1))) + s_cb(i + 1)) + 2d0*(s_cb(i + 2) - s_cb(i))*((s_cb(i + 2) - & + s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))))/((s_cb(i) - & + s_cb(i + 2))*(s_cb(i) - s_cb(i + 3))**2d0*(s_cb(i + 3) - & + s_cb(i + 1))) beta_coef_${XYZ}$ (i + 1, 0, 2) = & 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(10d0*(s_cb(i + 1) - & s_cb(i))**2d0 + (s_cb(i + 1) - s_cb(i))*((s_cb(i + 2) - & - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))) + ((s_cb(i + 2) - & - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1)))**2d0)/((s_cb(i) - & - s_cb(i + 2))**2d0*(s_cb(i) - s_cb(i + 3))**2d0) + s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))) + ((s_cb(i + 2) - & + s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1)))**2d0)/((s_cb(i) - & + s_cb(i + 2))**2d0*(s_cb(i) - s_cb(i + 3))**2d0) beta_coef_${XYZ}$ (i + 1, 1, 0) = & 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(10d0*(s_cb(i + 1) - & s_cb(i))**2d0 + (s_cb(i) - s_cb(i - 1))**2d0 + (s_cb(i) - & - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) - & - s_cb(i + 2))**2d0*(s_cb(i) - s_cb(i + 2))**2d0) + s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) - & + s_cb(i + 2))**2d0*(s_cb(i) - s_cb(i + 2))**2d0) beta_coef_${XYZ}$ (i + 1, 1, 1) = & 4d0*(s_cb(i) - s_cb(i + 1))**2d0*((s_cb(i) - & s_cb(i + 1))*((s_cb(i) - s_cb(i - 1)) + 20d0*(s_cb(i + 1) - & - s_cb(i))) + (2d0*(s_cb(i) - s_cb(i - 1)) + (s_cb(i + 1) - & - s_cb(i)))*(s_cb(i + 2) - s_cb(i)))/((s_cb(i + 1) - & - s_cb(i - 1))*(s_cb(i - 1) - s_cb(i + 2))**2d0*(s_cb(i + 2) - & - s_cb(i))) + s_cb(i))) + (2d0*(s_cb(i) - s_cb(i - 1)) + (s_cb(i + 1) - & + s_cb(i)))*(s_cb(i + 2) - s_cb(i)))/((s_cb(i + 1) - & + s_cb(i - 1))*(s_cb(i - 1) - s_cb(i + 2))**2d0*(s_cb(i + 2) - & + s_cb(i))) beta_coef_${XYZ}$ (i + 1, 1, 2) = & 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(10d0*(s_cb(i + 1) - & s_cb(i))**2d0 + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - & - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2d0)/ & + s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2d0)/ & ((s_cb(i - 1) - s_cb(i + 1))**2d0*(s_cb(i - 1) - & s_cb(i + 2))**2d0) beta_coef_${XYZ}$ (i + 1, 2, 0) = & 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(12d0*(s_cb(i + 1) - & s_cb(i))**2d0 + ((s_cb(i) - s_cb(i - 2)) + (s_cb(i) - & - s_cb(i - 1)))**2d0 + 3d0*((s_cb(i) - s_cb(i - 2)) + & - (s_cb(i) - s_cb(i - 1)))*(s_cb(i + 1) - s_cb(i)))/ & + s_cb(i - 1)))**2d0 + 3d0*((s_cb(i) - s_cb(i - 2)) + & + (s_cb(i) - s_cb(i - 1)))*(s_cb(i + 1) - s_cb(i)))/ & ((s_cb(i - 2) - s_cb(i + 1))**2d0*(s_cb(i - 1) - & s_cb(i + 1))**2d0) beta_coef_${XYZ}$ (i + 1, 2, 1) = & 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(19d0*(s_cb(i + 1) - & s_cb(i))**2d0 + ((s_cb(i) - s_cb(i - 2))*(s_cb(i) - & - s_cb(i + 1))) + 2d0*(s_cb(i + 1) - s_cb(i - 1))*((s_cb(i) - & - s_cb(i - 2)) + (s_cb(i + 1) - s_cb(i - 1))))/((s_cb(i - 2) - & - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))**2d0*(s_cb(i + 1) - & - s_cb(i - 1))) + s_cb(i + 1))) + 2d0*(s_cb(i + 1) - s_cb(i - 1))*((s_cb(i) - & + s_cb(i - 2)) + (s_cb(i + 1) - s_cb(i - 1))))/((s_cb(i - 2) - & + s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))**2d0*(s_cb(i + 1) - & + s_cb(i - 1))) beta_coef_${XYZ}$ (i + 1, 2, 2) = & 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(10d0*(s_cb(i + 1) - & s_cb(i))**2d0 + (s_cb(i) - s_cb(i - 1))**2d0 + (s_cb(i) - & - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) - & - s_cb(i))**2d0*(s_cb(i - 2) - s_cb(i + 1))**2d0) + s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) - & + s_cb(i))**2d0*(s_cb(i - 2) - s_cb(i + 1))**2d0) end do @@ -453,11 +449,11 @@ contains ! END: Computing WENO5 Coefficients ================================ if (weno_dir == 1) then -!$acc update device(poly_coef_cbL_x, poly_coef_cbR_x, d_cbL_x, d_cbR_x, beta_coef_x) + !$acc update device(poly_coef_cbL_x, poly_coef_cbR_x, d_cbL_x, d_cbR_x, beta_coef_x) elseif (weno_dir == 2) then -!$acc update device(poly_coef_cbL_y, poly_coef_cbR_y, d_cbL_y, d_cbR_y, beta_coef_y) + !$acc update device(poly_coef_cbL_y, poly_coef_cbR_y, d_cbL_y, d_cbR_y, beta_coef_y) else -!$acc update device(poly_coef_cbL_z, poly_coef_cbR_z, d_cbL_z, d_cbR_z, beta_coef_z) + !$acc update device(poly_coef_cbL_z, poly_coef_cbR_z, d_cbL_z, d_cbR_z, beta_coef_z) end if ! Nullifying WENO coefficients and cell-boundary locations pointers @@ -467,11 +463,11 @@ contains end subroutine s_compute_weno_coefficients ! --------------------------- 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) + 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, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z + 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 @@ -490,8 +486,8 @@ contains is1 = is1_d is2 = is2_d is3 = is3_d - -!$acc update device(is1, is2, is3) + + !$acc update device(is1, is2, is3) if (weno_order /= 1) then call s_initialize_weno(v_vf, & @@ -500,7 +496,7 @@ contains if (weno_order == 1) then if (weno_dir == 1) then -!$acc parallel loop collapse(4) default(present) + !$acc parallel loop collapse(4) default(present) do i = 1, ubound(v_vf, 1) do l = is3%beg, is3%end do k = is2%beg, is2%end @@ -511,9 +507,9 @@ contains end do end do end do -!$acc end parallel loop + !$acc end parallel loop else if (weno_dir == 2) then -!$acc parallel loop collapse(4) default(present) + !$acc parallel loop collapse(4) default(present) do i = 1, ubound(v_vf, 1) do l = is3%beg, is3%end do k = is2%beg, is2%end @@ -524,9 +520,9 @@ contains end do end do end do -!$acc end parallel loop + !$acc end parallel loop else if (weno_dir == 3) then -!$acc parallel loop collapse(4) default(present) + !$acc parallel loop collapse(4) default(present) do i = 1, ubound(v_vf, 1) do l = is3%beg, is3%end do k = is2%beg, is2%end @@ -537,172 +533,171 @@ contains end do end do end do -!$acc end parallel loop + !$acc end parallel loop end if elseif (weno_order == 3) then #:for WENO_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - if (weno_dir == ${WENO_DIR}$) then -!$acc parallel loop collapse(4) gang vector default(present) private(beta,dvd,poly,omega,alpha) + if (weno_dir == ${WENO_DIR}$) 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_${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(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_${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) + 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_${XYZ}$(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_${XYZ}$(j, 1, 0)*dvd(-1)*dvd(-1) & + beta(1) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(-1)*dvd(-1) & + weno_eps - alpha = d_cbL_${XYZ}$(:, j)/(beta*beta) + alpha = d_cbL_${XYZ}$ (:, j)/(beta*beta) omega = alpha/sum(alpha) - if(mapped_weno) then + if (mapped_weno) then - 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)))) + 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_${XYZ}$(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_${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) + 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_${XYZ}$(:, j)/(beta*beta) + alpha = d_cbR_${XYZ}$ (:, j)/(beta*beta) omega = alpha/sum(alpha) - if(mapped_weno) then + if (mapped_weno) then - 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)))) + 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_${XYZ}$(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 end do end do -!$acc end parallel loop - end if + !$acc end parallel loop + end if #:endfor else #:for WENO_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - if (weno_dir == ${WENO_DIR}$) 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_${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_${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_${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_${XYZ}$(:, j)/(beta*beta) - - omega = alpha/sum(alpha) - - if(mapped_weno) then - - 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)))) + if (weno_dir == ${WENO_DIR}$) 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 - omega = alpha/sum(alpha) + 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_${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_${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 - end if + alpha = d_cbL_${XYZ}$ (:, j)/(beta*beta) + omega = alpha/sum(alpha) + + if (mapped_weno) then - vL_rs_vf_${XYZ}$(j, k, l, i) = sum(omega*poly) + 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)))) - 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) + omega = alpha/sum(alpha) - alpha = d_cbR_${XYZ}$(:, j)/(beta*beta) + end if - omega = alpha/sum(alpha) + vL_rs_vf_${XYZ}$ (j, k, l, i) = sum(omega*poly) - if(mapped_weno) then + 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_${XYZ}$(:, j)*(1d0 + d_cbR_${XYZ}$(:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbR_${XYZ}$(:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_${XYZ}$(:, j)))) + alpha = d_cbR_${XYZ}$ (:, j)/(beta*beta) omega = alpha/sum(alpha) - end if + if (mapped_weno) then + + 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)))) - vR_rs_vf_${XYZ}$(j, k, l, i) = sum(omega*poly) + omega = alpha/sum(alpha) + end if + + vR_rs_vf_${XYZ}$ (j, k, l, i) = sum(omega*poly) + + end do end do end do end do - end do -!$acc end parallel loop + !$acc end parallel loop - if (mp_weno) then - call s_preserve_monotonicity(v_rs_ws_${XYZ}$, vL_rs_vf_${XYZ}$, & - vR_rs_vf_${XYZ}$) - end if + if (mp_weno) then + call s_preserve_monotonicity(v_rs_ws_${XYZ}$, vL_rs_vf_${XYZ}$, & + vR_rs_vf_${XYZ}$) + end if - end if + end if #:endfor end if @@ -740,7 +735,7 @@ contains !$acc update device(v_size) if (weno_dir == 1) then -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do j = 1, v_size do q = is3%beg, is3%end do l = is2%beg, is2%end @@ -750,7 +745,7 @@ contains end do end do end do -!$acc end parallel loop + !$acc end parallel loop end if ! ================================================================== @@ -765,7 +760,7 @@ contains use CuTensorEx !$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]) + 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 @@ -773,13 +768,13 @@ contains use CuTensorEx !$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]) + 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 else #endif -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do j = 1, v_size do q = is3%beg, is3%end do l = is2%beg, is2%end @@ -806,12 +801,12 @@ contains use CuTensorEx !$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]) + 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 #endif -!$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(4) gang vector default(present) do j = 1, v_size do q = is3%beg, is3%end do l = is2%beg, is2%end @@ -831,8 +826,6 @@ contains end subroutine s_initialize_weno ! ------------------------------------- - - !> The goal of this subroutine is to ensure that the WENO !! reconstruction is monotonic. The latter is achieved by !! enforcing monotonicity preserving bounds of Suresh and @@ -850,7 +843,7 @@ contains real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: vL_rs_vf, vR_rs_vf integer :: i, j, k, l - + real(kind(0d0)), dimension(-1:1) :: d !< Curvature measures at the zone centers real(kind(0d0)) :: d_MD, d_LC !< @@ -870,16 +863,15 @@ contains !! may be utilized with the scheme. In theory, for stability, a CFL !! number less than 1/(1+alpha) is necessary. The default value for !! alpha is 2. - real(kind(0d0)), parameter :: beta = 4d0/3d0 !< !! Determines the amount of freedom available from utilizing a large !! value for the local curvature. The default value for beta is 4/3. real(kind(0d0)), parameter :: alpha_mp = 2d0 - real(kind(0d0)), parameter :: beta_mp = 4d0/3d0 + real(kind(0d0)), parameter :: beta_mp = 4d0/3d0 - !$acc parallel loop gang vector collapse (4) default(present) private(d) + !$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 @@ -936,10 +928,10 @@ contains vL_LC)) vL_rs_vf(j, k, l, i) = vL_rs_vf(j, k, l, i) & - + (sign(5d-1, vL_min - vL_rs_vf(j, k, l, i)) & - + sign(5d-1, vL_max - vL_rs_vf(j, k, l, i))) & - *min(abs(vL_min - vL_rs_vf(j, k, l, i)), & - abs(vL_max - vL_rs_vf(j, k, l, i))) + + (sign(5d-1, vL_min - vL_rs_vf(j, k, l, i)) & + + sign(5d-1, vL_max - vL_rs_vf(j, k, l, i))) & + *min(abs(vL_min - vL_rs_vf(j, k, l, i)), & + abs(vL_max - vL_rs_vf(j, k, l, i))) ! END: Left Monotonicity Preserving Bound ========================== ! Right Monotonicity Preserving Bound ============================== @@ -995,16 +987,16 @@ contains vR_LC)) vR_rs_vf(j, k, l, i) = vR_rs_vf(j, k, l, i) & - + (sign(5d-1, vR_min - vR_rs_vf(j, k, l, i)) & - + sign(5d-1, vR_max - vR_rs_vf(j, k, l, i))) & - *min(abs(vR_min - vR_rs_vf(j, k, l, i)), & - abs(vR_max - vR_rs_vf(j, k, l, i))) - ! END: Right Monotonicity Preserving Bound ========================= + + (sign(5d-1, vR_min - vR_rs_vf(j, k, l, i)) & + + sign(5d-1, vR_max - vR_rs_vf(j, k, l, i))) & + *min(abs(vR_min - vR_rs_vf(j, k, l, i)), & + abs(vR_max - vR_rs_vf(j, k, l, i))) + ! END: Right Monotonicity Preserving Bound ========================= end do end do end do end do -!$acc end parallel loop + !$acc end parallel loop end subroutine s_preserve_monotonicity ! ------------------------------- diff --git a/src/simulation/p_main.fpp b/src/simulation/p_main.fpp index 89824207d..3f0e885c8 100644 --- a/src/simulation/p_main.fpp +++ b/src/simulation/p_main.fpp @@ -58,12 +58,12 @@ program p_main do if (t_step == t_step_stop) then call s_save_performance_metrics(t_step, time_avg, time_final, io_time_avg, & - io_time_final, proc_time, io_proc_time, file_exists, start, finish, nt) - exit + io_time_final, proc_time, io_proc_time, file_exists, start, finish, nt) + exit end if call s_perform_time_step(t_step, time_avg, time_final, io_time_avg, io_time_final, & - proc_time, io_proc_time, file_exists, start, finish, nt) + proc_time, io_proc_time, file_exists, start, finish, nt) if (mod(t_step - t_step_start, t_step_save) == 0 .or. t_step == t_step_stop) then call s_save_data(t_step, start, finish, io_time_avg, nt) @@ -73,7 +73,7 @@ program p_main end do ! ========================================================================== - deallocate(proc_time, io_proc_time) + deallocate (proc_time, io_proc_time) call s_finalize_modules() diff --git a/src/syscheck/syscheck.fpp b/src/syscheck/syscheck.fpp index 7a67157e6..de613a6f8 100644 --- a/src/syscheck/syscheck.fpp +++ b/src/syscheck/syscheck.fpp @@ -2,7 +2,7 @@ #ifdef MFC_MPI if (rank == 0) then #endif - print *, ${','.join(args)}$ + print *, ${','.join(args)}$ #ifdef MFC_MPI end if #endif @@ -13,7 +13,7 @@ @:LOG("[TEST] MPI: ${','.join([ x.replace("'", '') for x in args ])}$") ${','.join([ x.replace("'", '') for x in args ])}$ if (ierr /= MPI_SUCCESS) then - print*, " -> Error: ", ierr + print *, " -> Error: ", ierr stop ierr end if #else @@ -71,7 +71,7 @@ program syscheck @:ACCC('!$acc enter data create(arr(1:N))') @:ACCC('!$acc parallel loop') @:ACC(do i = 1, N) - @:ACC(arr(i) = i) + @:ACC(arr(i) = i) @:ACC(end do) @:ACCC('!$acc update host(arr(1:N))') @:ACCC('!$acc exit data delete(arr)') @@ -85,14 +85,14 @@ program syscheck end program syscheck subroutine assert(condition) - + use iso_fortran_env, only: output_unit, error_unit - + logical, intent(in) :: condition - + if (.not. condition) then - call flush(int(output_unit)) - call flush(int(error_unit)) + call flush (int(output_unit)) + call flush (int(error_unit)) stop 1 end if diff --git a/toolchain/bootstrap/format.sh b/toolchain/bootstrap/format.sh index d6aea99de..77ad2abf6 100644 --- a/toolchain/bootstrap/format.sh +++ b/toolchain/bootstrap/format.sh @@ -1,18 +1,39 @@ #!/bin/bash -log "Formatting MFC with fprettify..." +log "Formatting MFC:" -fprettify ${@:-src} --exclude "src/*/autogen" --recursive --silent \ - --indent 4 --c-relations --enable-replacements --enable-decl \ - --whitespace-comma 1 --whitespace-multdiv 1 --whitespace-plusminus 1 \ - --case 1 1 1 1 --strict-indent -ret="$?" +fortran_files=$(find ${@:-src} -type f | grep -Ev 'src/.+/autogen/') -if [ "$ret" != '0' ]; then - error "failed to execute fprettify." - error "MFC has not been fprettify'ied." +longest=0 +for filepath in $fortran_files; do + if [ "${#filepath}" -gt "$longest" ]; then + longest="${#filepath}" + fi +done - exit 1 -fi +for filepath in $fortran_files; do + echo -n " > $filepath $(printf '%*s' "$((longest - ${#filepath}))" '')" -ok "MFC has been fprettify'ied." \ No newline at end of file + before=$(sha256sum "$filepath" | cut -d' ' -f1) + + python3 toolchain/indenter.py "$filepath" + + if ! fprettify "$filepath" \ + --silent --indent 4 --c-relations --enable-replacements --enable-decl \ + --whitespace-comma 1 --whitespace-multdiv 0 --whitespace-plusminus 1 \ + --case 1 1 1 1 --strict-indent --line-length 1000; then + error "failed to execute fprettify." + error "MFC has not been fprettify'ied." + exit 1 + fi + + after=$(sha256sum "$filepath" | cut -d' ' -f1) + + if [ "$before" != "$after" ]; then + echo -e "$YELLOW[formatted]$COLOR_RESET" + else + echo -e "$GREEN[unchanged]$COLOR_RESET" + fi +done + +ok "Done. MFC has been formatted." diff --git a/toolchain/indenter.py b/toolchain/indenter.py new file mode 100644 index 000000000..f09e29b0a --- /dev/null +++ b/toolchain/indenter.py @@ -0,0 +1,84 @@ +#!/usr/bin/env python3 + +import os, argparse + +def main(): + parser = argparse.ArgumentParser( + prog='indenter.py', + description='Adjust indentation of OpenACC directives in a Fortran file') + parser.add_argument('filepath', metavar='input_file', type=str, help='File to format') + args = vars(parser.parse_args()) + + filepath = args['filepath'] + + temp_filepath = f"{filepath}.new" + adjust_indentation(filepath, temp_filepath) + os.replace(temp_filepath, filepath) + +BLOCK_STARTERS = ('if', 'do', '#:if', '#:else') +BLOCK_ENDERS = ('end', 'contains', 'else', '#:end', '#:else') +LOOP_DIRECTIVES = ('!$acc loop', '!$acc parallel loop') + +# pylint: disable=too-many-branches +def adjust_indentation(input_file, output_file): + max_empty_lines=4 + indent_len=4 + + with open(input_file, 'r') as file_in, open(output_file, 'w') as file_out: + lines = file_in.readlines() + + # this makes sure !$acc lines that have line continuations get indented at proper level + # pylint: disable=too-many-nested-blocks + for _ in range(10): + # loop through file + # pylint: disable=consider-using-enumerate + for i in range(len(lines)): + if lines[i].lstrip().startswith('!$acc') and i + 1 < len(lines): + j = i + 1 + empty_lines = 0 + # look down to see how to indent a line + while j < len(lines) and empty_lines < max_empty_lines: + # if the following line starts with [end, else, contains], skip to looking up + if lines[j].lstrip().startswith(BLOCK_ENDERS): + empty_lines = max_empty_lines + # skip empty lines + elif lines[j].strip() == '': + empty_lines += 1 + # indent acc lines + elif not lines[j].lstrip().startswith('!$acc'): + indent = len(lines[j]) - len(lines[j].lstrip()) + lines[i] = ' ' * indent + lines[i].lstrip() + break + j += 1 + # if looking down just finds empty lines, start looking up for indentation level + if empty_lines == max_empty_lines: + k = i - 1 + while k >= 0: + # if line above is not empty + if lines[k].strip() != '': + # if line 2 above ends with line continuation, indent at that level + if lines[k-1].strip().endswith('&'): + indent = len(lines[k-1]) - len(lines[k-1].lstrip()) + # if line above starts a loop or branch, indent + elif lines[k].lstrip().startswith(BLOCK_STARTERS): + indent = indent_len + (len(lines[k]) - len(lines[k].lstrip())) + # else indent at level of line above + else: + indent = len(lines[k]) - len(lines[k].lstrip()) + lines[i] = ' ' * indent + lines[i].lstrip() + break + k -= 1 + + # remove empty lines following an acc loop directive + i = 0 + while i < len(lines): + if lines[i].lstrip().startswith(LOOP_DIRECTIVES) and \ + i+1 < len(lines) and lines[i+1].strip() == '': + file_out.write(lines[i]) + i += 2 + else: + file_out.write(lines[i]) + i += 1 + +if __name__ == "__main__": + main()