diff --git a/src/bc_tgv.f90 b/src/bc_tgv.f90 index 4377cd8..aaf88e5 100644 --- a/src/bc_tgv.f90 +++ b/src/bc_tgv.f90 @@ -4,265 +4,265 @@ module bc_tgv - use MPI + use MPI - use decomp_2d, only : mytype, real_type, decomp_2d_warning - use decomp_2d, only : nrank, nproc, xsize, xstart - use x3d_precision, only : pi, twopi - use variables, only : nx, ny, nz - use param, only : dx, dy, dz, xlx, yly, zlz, dt, xnu - use param, only : zero, one, two + use decomp_2d, only: mytype, real_type, decomp_2d_warning + use decomp_2d, only: nrank, nproc, xsize, xstart + use x3d_precision, only: pi, twopi + use variables, only: nx, ny, nz + use param, only: dx, dy, dz, xlx, yly, zlz, dt, xnu + use param, only: zero, one, two - implicit none + implicit none - integer, save :: tgv_iounit - integer, parameter :: tgv_verbose = 0 - character(len=*), parameter :: tgv_file = "tgv.dat" + integer, save :: tgv_iounit + integer, parameter :: tgv_verbose = 0 + character(len=*), parameter :: tgv_file = "tgv.dat" - ! Make everything private unless declared public - private - public :: tgv_boot, & - tgv_listing, & - tgv_init, & - tgv_postprocess, & - tgv_finalize + ! Make everything private unless declared public + private + public :: tgv_boot, & + tgv_listing, & + tgv_init, & + tgv_postprocess, & + tgv_finalize contains - ! - ! Initialize case-specific parameters and IO - ! - subroutine tgv_boot() - - use variables, only : nxm, nym, nzm - use param, only : dt, dx, dy, dz, dx2, dy2, dz2, & - xlx, yly, zlz, re, xnu, one - - implicit none - - ! Local variable - logical :: fexists - - ! Default domain size is 2 pi x 2 pi x 2 pi - ! This should be inside input.i3d - xlx = twopi - yly = twopi - zlz = twopi - dx = xlx / real(nxm, mytype) - dy = yly / real(nym, mytype) - dz = zlz / real(nzm, mytype) - dx2 = dx * dx - dy2 = dy * dy - dz2 = dz * dz - - ! Default time step : CFL = 0.2 and U = 1 - ! This should be inside input.i3d ? - dt = 0.1_mytype * dx - - ! Default Re is 1600 when Re = 0 - ! This should be inside input.i3d ? - if (abs(re) <= epsilon(re)) then - re = 1600._mytype - xnu = one / re - endif - - ! Check if the file is present and get IO unit - if (nrank == 0) then - - inquire(file=tgv_file, exist=fexists) - if (fexists) then - if (tgv_verbose > 0) call decomp_2d_warning(1, "TGV: file "//tgv_file//" replaced.") - open(newunit=tgv_iounit, file=tgv_file, action='write', status='replace') - else - open(newunit=tgv_iounit, file=tgv_file, action='write', status='new') - endif - - endif - - end subroutine tgv_boot - - ! - ! Case-specific parameters in the listing - ! - subroutine tgv_listing() - - implicit none - - if (nrank == 0) then - write(*,*)' 3D TGV test case' - write(*,*)'===========================================================' - endif - - end subroutine tgv_listing - - ! - ! Initialize 3D fields - ! - subroutine tgv_init(ux1, uy1, uz1) - - implicit none - - ! Arguments - real(mytype),intent(out),dimension(xsize(1),xsize(2),xsize(3)) :: ux1,uy1,uz1 - - ! Local variables - real(mytype) :: x, y, z - integer :: i, j, k, ip, it - - ! Initial velocity - do concurrent (k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) - z = (k + xstart(3) - 2) * dz - y = (j + xstart(2) - 2) * dy - x = (i + xstart(1) - 2) * dx - ux1(i, j, k) = sin(twopi * (x / xlx)) * cos(twopi * (y / yly)) * cos(twopi * (z / zlz)) - uy1(i, j, k) = -cos(twopi * (x / xlx)) * sin(twopi * (y / yly)) * cos(twopi * (z / zlz)) - uz1(i, j, k) = zero - enddo - - ! Check initial TKE, dissipation and enstrophy - call tgv_postprocess(ux1, uy1, uz1, 1) - - endsubroutine tgv_init - - ! - ! Compute and log various statistics - ! - subroutine tgv_postprocess(ux1, uy1, uz1, ndt) - - use decomp_2d, only : mytype, real_type, decomp_2d_abort, xsize, ysize, zsize - use param, only : half, two, xnu, dt - use variables, only : nx, ny, nz, ppy - use var, only : ux2,uy2,uz2,ux3,uy3,uz3 - use var, only : ta1,tb1,tc1,td1,te1,tf1,tg1,th1,ti1 - use var, only : ta2,tb2,tc2 - use var, only : ta3,tb3,tc3 - use x3d_derive - use x3d_transpose - use x3d_operator_1d - - implicit none - - ! Arguments - real(mytype), dimension(xsize(1),xsize(2),xsize(3)), intent(in) :: ux1, uy1, uz1 - integer, intent(in) :: ndt - - ! Local variables - real(mytype) :: x, y, z, tke, eps, eps2, enst - integer :: code - - ! Collect statistics at each time step currently - if (mod(ndt, 1) /= 0) return - - ! This is needed to compute derivatives - call x3d_transpose_x_to_y(ux1, ux2) - call x3d_transpose_x_to_y(uy1, uy2) - call x3d_transpose_x_to_y(uz1, uz2) - call x3d_transpose_y_to_z(ux2, ux3) - call x3d_transpose_y_to_z(uy2, uy3) - call x3d_transpose_y_to_z(uz2, uz3) - - ! Compute X derivative - call derx (ta1,ux1,x3d_op_derx, xsize(1),xsize(2),xsize(3)) - call derx (tb1,uy1,x3d_op_derxp,xsize(1),xsize(2),xsize(3)) - call derx (tc1,uz1,x3d_op_derxp,xsize(1),xsize(2),xsize(3)) - - ! Compute Y derivative and transpose back to X - call dery (ta2,ux2,x3d_op_deryp,ppy,ysize(1),ysize(2),ysize(3)) - call dery (tb2,uy2,x3d_op_dery ,ppy,ysize(1),ysize(2),ysize(3)) - call dery (tc2,uz2,x3d_op_deryp,ppy,ysize(1),ysize(2),ysize(3)) - call x3d_transpose_y_to_x(ta2, td1) - call x3d_transpose_y_to_x(tb2, te1) - call x3d_transpose_y_to_x(tc2, tf1) - - ! Compute Z derivative and transpose back to X - call derz (ta3,ux3,x3d_op_derzp,zsize(1),zsize(2),zsize(3)) - call derz (tb3,uy3,x3d_op_derzp,zsize(1),zsize(2),zsize(3)) - call derz (tc3,uz3,x3d_op_derz ,zsize(1),zsize(2),zsize(3)) - call x3d_transpose_z_to_y(ta3, ta2) - call x3d_transpose_z_to_y(tb3, tb2) - call x3d_transpose_z_to_y(tc3, tc2) - call x3d_transpose_y_to_x(ta2, tg1) - call x3d_transpose_y_to_x(tb2, th1) - call x3d_transpose_y_to_x(tc2, ti1) - !du/dx=ta1 du/dy=td1 du/dz=tg1 - !dv/dx=tb1 dv/dy=te1 dv/dz=th1 - !dw/dx=tc1 dw/dy=tf1 dw/dz=ti1 - - ! Space-average of enstrophy - enst = half * sum((tf1-th1)**2 + (tg1-tc1)**2 + (tb1-td1)**2) - call MPI_ALLREDUCE(MPI_IN_PLACE,enst,1,real_type,MPI_SUM,MPI_COMM_WORLD,code) - if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, & - "MPI_ALLREDUCE") - enst = enst / (nx*ny*nz) - - ! Space-average of energy dissipation - eps = half * xnu * sum((two*ta1)**2 + (two*te1)**2 + (two*ti1)**2 + & - two*(td1+tb1)**2 + two*(tg1+tc1)**2 + two*(th1+tf1)**2) - call MPI_ALLREDUCE(MPI_IN_PLACE,eps,1,real_type,MPI_SUM,MPI_COMM_WORLD,code) - if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, & - "MPI_ALLREDUCE") - eps = eps / (nx*ny*nz) - - ! Space-average of TKE - tke = half * sum(ux1**2 + uy1**2 + uz1**2) - call MPI_ALLREDUCE(MPI_IN_PLACE,tke,1,real_type,MPI_SUM,MPI_COMM_WORLD,code) - if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, & - "MPI_ALLREDUCE") - tke = tke / (nx*ny*nz) - - ! Compute X second derivative - call derxx(ta1,ux1,x3d_op_derxx, xsize(1),xsize(2),xsize(3)) - call derxx(tb1,uy1,x3d_op_derxxp,xsize(1),xsize(2),xsize(3)) - call derxx(tc1,uz1,x3d_op_derxxp,xsize(1),xsize(2),xsize(3)) - - ! Compute Y second derivative and transpose back to X - call deryy(ta2,ux2,x3d_op_deryyp,ysize(1),ysize(2),ysize(3)) - call deryy(tb2,uy2,x3d_op_deryy ,ysize(1),ysize(2),ysize(3)) - call deryy(tc2,uz2,x3d_op_deryyp,ysize(1),ysize(2),ysize(3)) - call x3d_transpose_y_to_x(ta2, td1) - call x3d_transpose_y_to_x(tb2, te1) - call x3d_transpose_y_to_x(tc2, tf1) - - ! Compute Z second derivative and transpose back to X - call derzz(ta3,ux3,x3d_op_derzzp,zsize(1),zsize(2),zsize(3)) - call derzz(tb3,uy3,x3d_op_derzzp,zsize(1),zsize(2),zsize(3)) - call derzz(tc3,uz3,x3d_op_derzz ,zsize(1),zsize(2),zsize(3)) - call x3d_transpose_z_to_y(ta3, ta2) - call x3d_transpose_z_to_y(tb3, tb2) - call x3d_transpose_z_to_y(tc3, tc2) - call x3d_transpose_y_to_x(ta2, tg1) - call x3d_transpose_y_to_x(tb2, th1) - call x3d_transpose_y_to_x(tc2, ti1) - !d²u/dxx=ta1 d²u/dyy=td1 d²u/dzz=tg1 - !d²v/dxx=tb1 d²v/dyy=te1 d²v/dzz=th1 - !d²w/dxx=tc1 d²w/dyy=tf1 d²w/dzz=ti1 - - ! Space average of energy dissipation with second derivatives - eps2 = - xnu * sum(ux1*(ta1+td1+tg1) + & - uy1*(tb1+te1+th1) + & - uz1*(tc1+tf1+ti1)) - call MPI_ALLREDUCE(MPI_IN_PLACE,eps2,1,real_type,MPI_SUM,MPI_COMM_WORLD,code) - if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, & - "MPI_ALLREDUCE") - eps2 = eps2 / (nx*ny*nz) - - ! Log - if (nrank == 0) then - write(tgv_iounit,'(20e20.12)') (ndt-1)*dt, tke, eps, eps2, enst - call flush(tgv_iounit) - endif - - end subroutine tgv_postprocess - - ! - ! Finalize case-specific IO - ! - subroutine tgv_finalize() - - implicit none - - if (nrank == 0) close(tgv_iounit) - - end subroutine tgv_finalize + ! + ! Initialize case-specific parameters and IO + ! + subroutine tgv_boot() + + use variables, only: nxm, nym, nzm + use param, only: dt, dx, dy, dz, dx2, dy2, dz2, & + xlx, yly, zlz, re, xnu, one + + implicit none + + ! Local variable + logical :: fexists + + ! Default domain size is 2 pi x 2 pi x 2 pi + ! This should be inside input.i3d + xlx = twopi + yly = twopi + zlz = twopi + dx = xlx/real(nxm, mytype) + dy = yly/real(nym, mytype) + dz = zlz/real(nzm, mytype) + dx2 = dx*dx + dy2 = dy*dy + dz2 = dz*dz + + ! Default time step : CFL = 0.2 and U = 1 + ! This should be inside input.i3d ? + dt = 0.1_mytype*dx + + ! Default Re is 1600 when Re = 0 + ! This should be inside input.i3d ? + if (abs(re) <= epsilon(re)) then + re = 1600._mytype + xnu = one/re + end if + + ! Check if the file is present and get IO unit + if (nrank == 0) then + + inquire (file=tgv_file, exist=fexists) + if (fexists) then + if (tgv_verbose > 0) call decomp_2d_warning(1, "TGV: file "//tgv_file//" replaced.") + open (newunit=tgv_iounit, file=tgv_file, action='write', status='replace') + else + open (newunit=tgv_iounit, file=tgv_file, action='write', status='new') + end if + + end if + + end subroutine tgv_boot + + ! + ! Case-specific parameters in the listing + ! + subroutine tgv_listing() + + implicit none + + if (nrank == 0) then + write (*, *) ' 3D TGV test case' + write (*, *) '===========================================================' + end if + + end subroutine tgv_listing + + ! + ! Initialize 3D fields + ! + subroutine tgv_init(ux1, uy1, uz1) + + implicit none + + ! Arguments + real(mytype), intent(out), dimension(xsize(1), xsize(2), xsize(3)) :: ux1, uy1, uz1 + + ! Local variables + real(mytype) :: x, y, z + integer :: i, j, k, ip, it + + ! Initial velocity + do concurrent(k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) + z = (k + xstart(3) - 2)*dz + y = (j + xstart(2) - 2)*dy + x = (i + xstart(1) - 2)*dx + ux1(i, j, k) = sin(twopi*(x/xlx))*cos(twopi*(y/yly))*cos(twopi*(z/zlz)) + uy1(i, j, k) = -cos(twopi*(x/xlx))*sin(twopi*(y/yly))*cos(twopi*(z/zlz)) + uz1(i, j, k) = zero + end do + + ! Check initial TKE, dissipation and enstrophy + call tgv_postprocess(ux1, uy1, uz1, 1) + + end subroutine tgv_init + + ! + ! Compute and log various statistics + ! + subroutine tgv_postprocess(ux1, uy1, uz1, ndt) + + use decomp_2d, only: mytype, real_type, decomp_2d_abort, xsize, ysize, zsize + use param, only: half, two, xnu, dt + use variables, only: nx, ny, nz, ppy + use var, only: ux2, uy2, uz2, ux3, uy3, uz3 + use var, only: ta1, tb1, tc1, td1, te1, tf1, tg1, th1, ti1 + use var, only: ta2, tb2, tc2 + use var, only: ta3, tb3, tc3 + use x3d_derive + use x3d_transpose + use x3d_operator_1d + + implicit none + + ! Arguments + real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: ux1, uy1, uz1 + integer, intent(in) :: ndt + + ! Local variables + real(mytype) :: x, y, z, tke, eps, eps2, enst + integer :: code + + ! Collect statistics at each time step currently + if (mod(ndt, 1) /= 0) return + + ! This is needed to compute derivatives + call x3d_transpose_x_to_y(ux1, ux2) + call x3d_transpose_x_to_y(uy1, uy2) + call x3d_transpose_x_to_y(uz1, uz2) + call x3d_transpose_y_to_z(ux2, ux3) + call x3d_transpose_y_to_z(uy2, uy3) + call x3d_transpose_y_to_z(uz2, uz3) + + ! Compute X derivative + call derx(ta1, ux1, x3d_op_derx, xsize(1), xsize(2), xsize(3)) + call derx(tb1, uy1, x3d_op_derxp, xsize(1), xsize(2), xsize(3)) + call derx(tc1, uz1, x3d_op_derxp, xsize(1), xsize(2), xsize(3)) + + ! Compute Y derivative and transpose back to X + call dery(ta2, ux2, x3d_op_deryp, ppy, ysize(1), ysize(2), ysize(3)) + call dery(tb2, uy2, x3d_op_dery, ppy, ysize(1), ysize(2), ysize(3)) + call dery(tc2, uz2, x3d_op_deryp, ppy, ysize(1), ysize(2), ysize(3)) + call x3d_transpose_y_to_x(ta2, td1) + call x3d_transpose_y_to_x(tb2, te1) + call x3d_transpose_y_to_x(tc2, tf1) + + ! Compute Z derivative and transpose back to X + call derz(ta3, ux3, x3d_op_derzp, zsize(1), zsize(2), zsize(3)) + call derz(tb3, uy3, x3d_op_derzp, zsize(1), zsize(2), zsize(3)) + call derz(tc3, uz3, x3d_op_derz, zsize(1), zsize(2), zsize(3)) + call x3d_transpose_z_to_y(ta3, ta2) + call x3d_transpose_z_to_y(tb3, tb2) + call x3d_transpose_z_to_y(tc3, tc2) + call x3d_transpose_y_to_x(ta2, tg1) + call x3d_transpose_y_to_x(tb2, th1) + call x3d_transpose_y_to_x(tc2, ti1) + !du/dx=ta1 du/dy=td1 du/dz=tg1 + !dv/dx=tb1 dv/dy=te1 dv/dz=th1 + !dw/dx=tc1 dw/dy=tf1 dw/dz=ti1 + + ! Space-average of enstrophy + enst = half*sum((tf1 - th1)**2 + (tg1 - tc1)**2 + (tb1 - td1)**2) + call MPI_ALLREDUCE(MPI_IN_PLACE, enst, 1, real_type, MPI_SUM, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code & + , "MPI_ALLREDUCE") + enst = enst/(nx*ny*nz) + + ! Space-average of energy dissipation + eps = half*xnu*sum((two*ta1)**2 + (two*te1)**2 + (two*ti1)**2 + & + two*(td1 + tb1)**2 + two*(tg1 + tc1)**2 + two*(th1 + tf1)**2) + call MPI_ALLREDUCE(MPI_IN_PLACE, eps, 1, real_type, MPI_SUM, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code & + , "MPI_ALLREDUCE") + eps = eps/(nx*ny*nz) + + ! Space-average of TKE + tke = half*sum(ux1**2 + uy1**2 + uz1**2) + call MPI_ALLREDUCE(MPI_IN_PLACE, tke, 1, real_type, MPI_SUM, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code & + , "MPI_ALLREDUCE") + tke = tke/(nx*ny*nz) + + ! Compute X second derivative + call derxx(ta1, ux1, x3d_op_derxx, xsize(1), xsize(2), xsize(3)) + call derxx(tb1, uy1, x3d_op_derxxp, xsize(1), xsize(2), xsize(3)) + call derxx(tc1, uz1, x3d_op_derxxp, xsize(1), xsize(2), xsize(3)) + + ! Compute Y second derivative and transpose back to X + call deryy(ta2, ux2, x3d_op_deryyp, ysize(1), ysize(2), ysize(3)) + call deryy(tb2, uy2, x3d_op_deryy, ysize(1), ysize(2), ysize(3)) + call deryy(tc2, uz2, x3d_op_deryyp, ysize(1), ysize(2), ysize(3)) + call x3d_transpose_y_to_x(ta2, td1) + call x3d_transpose_y_to_x(tb2, te1) + call x3d_transpose_y_to_x(tc2, tf1) + + ! Compute Z second derivative and transpose back to X + call derzz(ta3, ux3, x3d_op_derzzp, zsize(1), zsize(2), zsize(3)) + call derzz(tb3, uy3, x3d_op_derzzp, zsize(1), zsize(2), zsize(3)) + call derzz(tc3, uz3, x3d_op_derzz, zsize(1), zsize(2), zsize(3)) + call x3d_transpose_z_to_y(ta3, ta2) + call x3d_transpose_z_to_y(tb3, tb2) + call x3d_transpose_z_to_y(tc3, tc2) + call x3d_transpose_y_to_x(ta2, tg1) + call x3d_transpose_y_to_x(tb2, th1) + call x3d_transpose_y_to_x(tc2, ti1) + !d²u/dxx=ta1 d²u/dyy=td1 d²u/dzz=tg1 + !d²v/dxx=tb1 d²v/dyy=te1 d²v/dzz=th1 + !d²w/dxx=tc1 d²w/dyy=tf1 d²w/dzz=ti1 + + ! Space average of energy dissipation with second derivatives + eps2 = -xnu*sum(ux1*(ta1 + td1 + tg1) + & + uy1*(tb1 + te1 + th1) + & + uz1*(tc1 + tf1 + ti1)) + call MPI_ALLREDUCE(MPI_IN_PLACE, eps2, 1, real_type, MPI_SUM, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code & + , "MPI_ALLREDUCE") + eps2 = eps2/(nx*ny*nz) + + ! Log + if (nrank == 0) then + write (tgv_iounit, '(20e20.12)') (ndt - 1)*dt, tke, eps, eps2, enst + call flush (tgv_iounit) + end if + + end subroutine tgv_postprocess + + ! + ! Finalize case-specific IO + ! + subroutine tgv_finalize() + + implicit none + + if (nrank == 0) close (tgv_iounit) + + end subroutine tgv_finalize end module bc_tgv diff --git a/src/bc_tgv2d.f90 b/src/bc_tgv2d.f90 index 69e0eaa..affeb28 100644 --- a/src/bc_tgv2d.f90 +++ b/src/bc_tgv2d.f90 @@ -4,292 +4,292 @@ module bc_tgv2d - use MPI + use MPI - use decomp_2d, only : mytype, real_type, decomp_2d_warning - use decomp_2d, only : nrank, nproc, xsize, xstart - use x3d_precision, only : pi, twopi - use variables, only : nx, ny, nz - use param, only : dx, dy, dz, xlx, yly, zlz, dt, xnu - use param, only : zero, one, two + use decomp_2d, only: mytype, real_type, decomp_2d_warning + use decomp_2d, only: nrank, nproc, xsize, xstart + use x3d_precision, only: pi, twopi + use variables, only: nx, ny, nz + use param, only: dx, dy, dz, xlx, yly, zlz, dt, xnu + use param, only: zero, one, two - implicit none + implicit none - integer, save :: tgv2d_iounit - integer, parameter :: tgv2d_verbose = 0 - character(len=*), parameter :: tgv2d_file = "tgv2d.dat" + integer, save :: tgv2d_iounit + integer, parameter :: tgv2d_verbose = 0 + character(len=*), parameter :: tgv2d_file = "tgv2d.dat" - ! Make everything private unless declared public - private - public :: tgv2d_boot, & - tgv2d_listing, & - tgv2d_init, & - tgv2d_postprocess, & - tgv2d_finalize + ! Make everything private unless declared public + private + public :: tgv2d_boot, & + tgv2d_listing, & + tgv2d_init, & + tgv2d_postprocess, & + tgv2d_finalize contains - ! - ! Initialize case-specific parameters and IO - ! - subroutine tgv2d_boot() - - use variables, only : nxm, nym, nzm - use param, only : dt, dx, dy, dz, dx2, dy2, dz2, & - xlx, yly, zlz, re, xnu, one - - implicit none - - ! Local variable - logical :: fexists - - ! Default domain size is 2 pi x 2 pi x 1 - ! This should be inside input.i3d - xlx = twopi - yly = twopi - zlz = one - dx = xlx / real(nxm, mytype) - dy = yly / real(nym, mytype) - dz = zlz / real(nzm, mytype) - dx2 = dx * dx - dy2 = dy * dy - dz2 = dz * dz - - ! Default time step : CFL = 0.2 and U = 1 - ! This should be inside input.i3d ? - dt = 0.2_mytype * dx - - ! Default Re is 1600 when Re = 0 - ! This should be inside input.i3d ? - if (abs(re) <= epsilon(re)) then - re = 1600._mytype - xnu = one / re - endif - - ! Check if the file is present and get IO unit - if (nrank == 0) then - - inquire(file=tgv2d_file, exist=fexists) - if (fexists) then - if (tgv2d_verbose > 0) call decomp_2d_warning(1, "TGV2D: file "//tgv2d_file//" replaced.") - open(newunit=tgv2d_iounit, file=tgv2d_file, action='write', status='replace') - else - open(newunit=tgv2d_iounit, file=tgv2d_file, action='write', status='new') - endif - - endif - - end subroutine tgv2d_boot - - ! - ! Case-specific parameters in the listing - ! - subroutine tgv2d_listing() - - implicit none - - if (nrank == 0) then - write(*,*)' 2D TGV test case' - write(*,*)' Error estimator valid for explicit Euler only' - write(*,*)'===========================================================' - endif - - end subroutine tgv2d_listing - - ! - ! Initialize 3D fields - ! - subroutine tgv2d_init(ux1, uy1, uz1) - - implicit none - - ! Arguments - real(mytype),intent(out),dimension(xsize(1),xsize(2),xsize(3)) :: ux1,uy1,uz1 - - ! Local variables - real(mytype) :: x, y, z - integer :: i, j, k, ip, it - - ! Initial velocity - do concurrent (k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) - z = (k + xstart(3) - 2) * dz - y = (j + xstart(2) - 2) * dy - x = (i + xstart(1) - 2) * dx - ux1(i, j, k) = sin(twopi * (x / xlx)) * cos(twopi * (y / yly)) - uy1(i, j, k) = -cos(twopi * (x / xlx)) * sin(twopi * (y / yly)) - uz1(i, j, k) = zero - enddo - - ! Check initial error - call tgv2d_postprocess(ux1, uy1, uz1, 1) - - endsubroutine tgv2d_init - - ! - ! Compare the velocity field with the analytical solution - ! - subroutine tgv2d_postprocess(ux1, uy1, uz1, ndt) - - implicit none - - ! Arguments - real(mytype), dimension(xsize(1),xsize(2),xsize(3)), intent(in) :: ux1, uy1, uz1 - integer, intent(in) :: ndt - - ! Local variables - real(mytype) :: x, y, z, factor, kxtgv, kytgv, kx2tgv, ky2tgv - real(mytype), dimension(3) :: sol, err_l1, err_l2, err_linf, uvw_max, uvw_min - integer :: i, j, k, it, code - - ! Temporal variation (explicit Euler time scheme) - kxtgv = twopi / xlx - kytgv = twopi / yly - call compute_kx2(kxtgv, kx2tgv) - call compute_ky2(kytgv, ky2tgv) - factor = one - do it = 2, ndt - factor = factor * (one - dt*xnu*(kx2tgv+ky2tgv)) - enddo - - ! Init - err_l1(:) = zero - err_l2(:) = zero - err_linf(:) = zero - - do k = 1, xsize(3) - z = (k + xstart(3) - 2)*dz - do j = 1, xsize(2) - y = (j + xstart(2) - 2)*dy - do i = 1, xsize(1) - x = (i + xstart(1) - 2)*dx - - ! Initial condition - sol(1) = sin(twopi * (x / xlx)) * cos(twopi * (y / yly)) - sol(2) = -cos(twopi * (x / xlx)) * sin(twopi * (y / yly)) - sol(3) = zero - - ! Analytical discrete solution - sol(:) = sol(:) * factor - - ! Update the errors - err_l1(1) = err_l1(1) + abs(ux1(i,j,k) - sol(1)) - err_l1(2) = err_l1(2) + abs(uy1(i,j,k) - sol(2)) - err_l1(3) = err_l1(3) + abs(uz1(i,j,k) - sol(3)) - err_l2(1) = err_l2(1) + (ux1(i,j,k) - sol(1))**2 - err_l2(2) = err_l2(2) + (uy1(i,j,k) - sol(2))**2 - err_l2(3) = err_l2(3) + (uz1(i,j,k) - sol(3))**2 - err_linf(1) = max(err_linf(1), abs(ux1(i,j,k)-sol(1))) - err_linf(2) = max(err_linf(2), abs(uy1(i,j,k)-sol(2))) - err_linf(3) = max(err_linf(3), abs(uz1(i,j,k)-sol(3))) - - enddo - enddo - enddo - - uvw_max(1) = maxval(ux1) - uvw_max(2) = maxval(uy1) - uvw_max(3) = maxval(uz1) - uvw_min(1) = minval(ux1) - uvw_min(2) = minval(uy1) - uvw_min(3) = minval(uz1) - - ! Compute global errors if needed - if (nproc > 1) then - call MPI_ALLREDUCE(MPI_IN_PLACE, err_l1, 3, real_type, MPI_SUM, MPI_COMM_WORLD, code) - if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_ALLREDUCE") - call MPI_ALLREDUCE(MPI_IN_PLACE, err_l2, 3, real_type, MPI_SUM, MPI_COMM_WORLD, code) - if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_ALLREDUCE") - call MPI_ALLREDUCE(MPI_IN_PLACE, err_linf, 3, real_type, MPI_MAX, MPI_COMM_WORLD, code) - if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_ALLREDUCE") - call MPI_ALLREDUCE(MPI_IN_PLACE, uvw_max, 3, real_type, MPI_MAX, MPI_COMM_WORLD, code) - if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_ALLREDUCE") - call MPI_ALLREDUCE(MPI_IN_PLACE, uvw_min, 3, real_type, MPI_MIN, MPI_COMM_WORLD, code) - if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_ALLREDUCE") - endif - - ! Rescale L1 and L2 errors - err_l1(:) = err_l1(:) / dble(nx*ny*nz) - err_l2(:) = sqrt(err_l2(:) / dble(nx*ny*nz)) - - ! Print the error for each velocity component - if (nrank == 0) then - ! Listing - write(*,*) "Max: ", uvw_max - write(*,*) "Min: ", uvw_min - write(*,*) "Amplitude: ", real(uvw_max-uvw_min) - write(*,*) "TGV 2D error, u, ", err_l1(1), err_l2(1), err_linf(1) - write(*,*) "TGV 2D error, v, ", err_l1(2), err_l2(2), err_linf(2) - write(*,*) "TGV 2D error, w, ", err_l1(3), err_l2(3), err_linf(3) - ! tgv2d.dat - write(tgv2d_iounit,*) "Max: ", ndt, uvw_max - write(tgv2d_iounit,*) "Min: ", ndt, uvw_min - write(tgv2d_iounit,*) "Amplitude: ", ndt, real(uvw_max-uvw_min) - write(tgv2d_iounit,*) "TGV 2D error, u, ", ndt, err_l1(1), err_l2(1), err_linf(1) - write(tgv2d_iounit,*) "TGV 2D error, v, ", ndt, err_l1(2), err_l2(2), err_linf(2) - write(tgv2d_iounit,*) "TGV 2D error, w, ", ndt, err_l1(3), err_l2(3), err_linf(3) - endif - - end subroutine tgv2d_postprocess - - ! - ! Finalize case-specific IO - ! - subroutine tgv2d_finalize() - - implicit none - - if (nrank == 0) close(tgv2d_iounit) - - end subroutine tgv2d_finalize - - ! - ! Compute the modified wavenumber for the second derivative in x - ! - subroutine compute_kx2(kin,k2out) - - use param, only : dx2, three, four, half, nine, eight - use x3d_operator_x_data - - implicit none - - real(mytype), intent(in) :: kin - real(mytype), intent(out) :: k2out - - if (kin.lt.zero .or. kin.gt.pi/min(dx,dy)) then - if (nrank==0) write(*,*) "TGV2D: Warning, incorrect wavenumber provided." - endif - - k2out = asix * two * (one - cos(kin*dx)) & - + four * bsix * half * (one - cos(two*kin*dx)) & - + nine * csix * (two / nine) * (one - cos(three*kin*dx)) & - + 16._mytype * dsix * (one / eight) * (one - cos(four*kin*dx)) - k2out = k2out / (one + two * alsaix * cos(kin*dx)) - - end subroutine compute_kx2 - - ! - ! Compute the modified wavenumber for the second derivative in y - ! - subroutine compute_ky2(kin,k2out) - - use param, only : dx2, three, four, half, nine, eight - use x3d_operator_y_data - - implicit none - - real(mytype), intent(in) :: kin - real(mytype), intent(out) :: k2out - - if (kin.lt.zero .or. kin.gt.pi/min(dx,dy)) then - if (nrank==0) write(*,*) "TGV2D: Warning, incorrect wavenumber provided." - endif - - k2out = asjy * two * (one - cos(kin*dx)) & - + four * bsjy * half * (one - cos(two*kin*dx)) & - + nine * csjy * (two / nine) * (one - cos(three*kin*dx)) & - + 16._mytype * dsjy * (one / eight) * (one - cos(four*kin*dx)) - k2out = k2out / (one + two * alsajy * cos(kin*dx)) - - end subroutine compute_ky2 + ! + ! Initialize case-specific parameters and IO + ! + subroutine tgv2d_boot() + + use variables, only: nxm, nym, nzm + use param, only: dt, dx, dy, dz, dx2, dy2, dz2, & + xlx, yly, zlz, re, xnu, one + + implicit none + + ! Local variable + logical :: fexists + + ! Default domain size is 2 pi x 2 pi x 1 + ! This should be inside input.i3d + xlx = twopi + yly = twopi + zlz = one + dx = xlx/real(nxm, mytype) + dy = yly/real(nym, mytype) + dz = zlz/real(nzm, mytype) + dx2 = dx*dx + dy2 = dy*dy + dz2 = dz*dz + + ! Default time step : CFL = 0.2 and U = 1 + ! This should be inside input.i3d ? + dt = 0.2_mytype*dx + + ! Default Re is 1600 when Re = 0 + ! This should be inside input.i3d ? + if (abs(re) <= epsilon(re)) then + re = 1600._mytype + xnu = one/re + end if + + ! Check if the file is present and get IO unit + if (nrank == 0) then + + inquire (file=tgv2d_file, exist=fexists) + if (fexists) then + if (tgv2d_verbose > 0) call decomp_2d_warning(1, "TGV2D: file "//tgv2d_file//" replaced.") + open (newunit=tgv2d_iounit, file=tgv2d_file, action='write', status='replace') + else + open (newunit=tgv2d_iounit, file=tgv2d_file, action='write', status='new') + end if + + end if + + end subroutine tgv2d_boot + + ! + ! Case-specific parameters in the listing + ! + subroutine tgv2d_listing() + + implicit none + + if (nrank == 0) then + write (*, *) ' 2D TGV test case' + write (*, *) ' Error estimator valid for explicit Euler only' + write (*, *) '===========================================================' + end if + + end subroutine tgv2d_listing + + ! + ! Initialize 3D fields + ! + subroutine tgv2d_init(ux1, uy1, uz1) + + implicit none + + ! Arguments + real(mytype), intent(out), dimension(xsize(1), xsize(2), xsize(3)) :: ux1, uy1, uz1 + + ! Local variables + real(mytype) :: x, y, z + integer :: i, j, k, ip, it + + ! Initial velocity + do concurrent(k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) + z = (k + xstart(3) - 2)*dz + y = (j + xstart(2) - 2)*dy + x = (i + xstart(1) - 2)*dx + ux1(i, j, k) = sin(twopi*(x/xlx))*cos(twopi*(y/yly)) + uy1(i, j, k) = -cos(twopi*(x/xlx))*sin(twopi*(y/yly)) + uz1(i, j, k) = zero + end do + + ! Check initial error + call tgv2d_postprocess(ux1, uy1, uz1, 1) + + end subroutine tgv2d_init + + ! + ! Compare the velocity field with the analytical solution + ! + subroutine tgv2d_postprocess(ux1, uy1, uz1, ndt) + + implicit none + + ! Arguments + real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: ux1, uy1, uz1 + integer, intent(in) :: ndt + + ! Local variables + real(mytype) :: x, y, z, factor, kxtgv, kytgv, kx2tgv, ky2tgv + real(mytype), dimension(3) :: sol, err_l1, err_l2, err_linf, uvw_max, uvw_min + integer :: i, j, k, it, code + + ! Temporal variation (explicit Euler time scheme) + kxtgv = twopi/xlx + kytgv = twopi/yly + call compute_kx2(kxtgv, kx2tgv) + call compute_ky2(kytgv, ky2tgv) + factor = one + do it = 2, ndt + factor = factor*(one - dt*xnu*(kx2tgv + ky2tgv)) + end do + + ! Init + err_l1(:) = zero + err_l2(:) = zero + err_linf(:) = zero + + do k = 1, xsize(3) + z = (k + xstart(3) - 2)*dz + do j = 1, xsize(2) + y = (j + xstart(2) - 2)*dy + do i = 1, xsize(1) + x = (i + xstart(1) - 2)*dx + + ! Initial condition + sol(1) = sin(twopi*(x/xlx))*cos(twopi*(y/yly)) + sol(2) = -cos(twopi*(x/xlx))*sin(twopi*(y/yly)) + sol(3) = zero + + ! Analytical discrete solution + sol(:) = sol(:)*factor + + ! Update the errors + err_l1(1) = err_l1(1) + abs(ux1(i, j, k) - sol(1)) + err_l1(2) = err_l1(2) + abs(uy1(i, j, k) - sol(2)) + err_l1(3) = err_l1(3) + abs(uz1(i, j, k) - sol(3)) + err_l2(1) = err_l2(1) + (ux1(i, j, k) - sol(1))**2 + err_l2(2) = err_l2(2) + (uy1(i, j, k) - sol(2))**2 + err_l2(3) = err_l2(3) + (uz1(i, j, k) - sol(3))**2 + err_linf(1) = max(err_linf(1), abs(ux1(i, j, k) - sol(1))) + err_linf(2) = max(err_linf(2), abs(uy1(i, j, k) - sol(2))) + err_linf(3) = max(err_linf(3), abs(uz1(i, j, k) - sol(3))) + + end do + end do + end do + + uvw_max(1) = maxval(ux1) + uvw_max(2) = maxval(uy1) + uvw_max(3) = maxval(uz1) + uvw_min(1) = minval(ux1) + uvw_min(2) = minval(uy1) + uvw_min(3) = minval(uz1) + + ! Compute global errors if needed + if (nproc > 1) then + call MPI_ALLREDUCE(MPI_IN_PLACE, err_l1, 3, real_type, MPI_SUM, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_ALLREDUCE") + call MPI_ALLREDUCE(MPI_IN_PLACE, err_l2, 3, real_type, MPI_SUM, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_ALLREDUCE") + call MPI_ALLREDUCE(MPI_IN_PLACE, err_linf, 3, real_type, MPI_MAX, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_ALLREDUCE") + call MPI_ALLREDUCE(MPI_IN_PLACE, uvw_max, 3, real_type, MPI_MAX, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_ALLREDUCE") + call MPI_ALLREDUCE(MPI_IN_PLACE, uvw_min, 3, real_type, MPI_MIN, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_ALLREDUCE") + end if + + ! Rescale L1 and L2 errors + err_l1(:) = err_l1(:)/dble(nx*ny*nz) + err_l2(:) = sqrt(err_l2(:)/dble(nx*ny*nz)) + + ! Print the error for each velocity component + if (nrank == 0) then + ! Listing + write (*, *) "Max: ", uvw_max + write (*, *) "Min: ", uvw_min + write (*, *) "Amplitude: ", real(uvw_max - uvw_min) + write (*, *) "TGV 2D error, u, ", err_l1(1), err_l2(1), err_linf(1) + write (*, *) "TGV 2D error, v, ", err_l1(2), err_l2(2), err_linf(2) + write (*, *) "TGV 2D error, w, ", err_l1(3), err_l2(3), err_linf(3) + ! tgv2d.dat + write (tgv2d_iounit, *) "Max: ", ndt, uvw_max + write (tgv2d_iounit, *) "Min: ", ndt, uvw_min + write (tgv2d_iounit, *) "Amplitude: ", ndt, real(uvw_max - uvw_min) + write (tgv2d_iounit, *) "TGV 2D error, u, ", ndt, err_l1(1), err_l2(1), err_linf(1) + write (tgv2d_iounit, *) "TGV 2D error, v, ", ndt, err_l1(2), err_l2(2), err_linf(2) + write (tgv2d_iounit, *) "TGV 2D error, w, ", ndt, err_l1(3), err_l2(3), err_linf(3) + end if + + end subroutine tgv2d_postprocess + + ! + ! Finalize case-specific IO + ! + subroutine tgv2d_finalize() + + implicit none + + if (nrank == 0) close (tgv2d_iounit) + + end subroutine tgv2d_finalize + + ! + ! Compute the modified wavenumber for the second derivative in x + ! + subroutine compute_kx2(kin, k2out) + + use param, only: three, four, half, nine, eight + use x3d_operator_x_data + + implicit none + + real(mytype), intent(in) :: kin + real(mytype), intent(out) :: k2out + + if (kin < zero .or. kin > pi/min(dx, dy)) then + if (nrank == 0) write (*, *) "TGV2D: Warning, incorrect wavenumber provided." + end if + + k2out = asix*two*(one - cos(kin*dx)) & + + four*bsix*half*(one - cos(two*kin*dx)) & + + nine*csix*(two/nine)*(one - cos(three*kin*dx)) & + + 16._mytype*dsix*(one/eight)*(one - cos(four*kin*dx)) + k2out = k2out/(one + two*alsaix*cos(kin*dx)) + + end subroutine compute_kx2 + + ! + ! Compute the modified wavenumber for the second derivative in y + ! + subroutine compute_ky2(kin, k2out) + + use param, only: three, four, half, nine, eight + use x3d_operator_y_data + + implicit none + + real(mytype), intent(in) :: kin + real(mytype), intent(out) :: k2out + + if (kin < zero .or. kin > pi/min(dx, dy)) then + if (nrank == 0) write (*, *) "TGV2D: Warning, incorrect wavenumber provided." + end if + + k2out = asjy*two*(one - cos(kin*dx)) & + + four*bsjy*half*(one - cos(two*kin*dx)) & + + nine*csjy*(two/nine)*(one - cos(three*kin*dx)) & + + 16._mytype*dsjy*(one/eight)*(one - cos(four*kin*dx)) + k2out = k2out/(one + two*alsajy*cos(kin*dx)) + + end subroutine compute_ky2 end module bc_tgv2d diff --git a/src/case.f90 b/src/case.f90 index d2d1049..461cbb0 100644 --- a/src/case.f90 +++ b/src/case.f90 @@ -4,142 +4,142 @@ module case - use param, only : itype, itype_tgv, itype_tgv2d - use decomp_2d, only : mytype, xsize + use param, only: itype, itype_tgv, itype_tgv2d + use decomp_2d, only: mytype, xsize - use bc_tgv - use bc_tgv2d + use bc_tgv + use bc_tgv2d - implicit none + implicit none - private ! All functions/subroutines private by default - public :: case_boot, & - case_listing, & - case_init, & - case_bc, & - case_forcing, & - case_visu, & - case_postprocess, & - case_finalize + private ! All functions/subroutines private by default + public :: case_boot, & + case_listing, & + case_init, & + case_bc, & + case_forcing, & + case_visu, & + case_postprocess, & + case_finalize contains - ! - ! Read case-specific parameters in the input file - ! Initialize case-specific IO - ! Allocate memory - ! - subroutine case_boot() + ! + ! Read case-specific parameters in the input file + ! Initialize case-specific IO + ! Allocate memory + ! + subroutine case_boot() - implicit none + implicit none - if (itype == itype_tgv) call tgv_boot() + if (itype == itype_tgv) call tgv_boot() - if (itype == itype_tgv2d) call tgv2d_boot() + if (itype == itype_tgv2d) call tgv2d_boot() - end subroutine case_boot + end subroutine case_boot - ! - ! Print case-specific parameters in the listing - ! - subroutine case_listing() + ! + ! Print case-specific parameters in the listing + ! + subroutine case_listing() - implicit none + implicit none - if (itype == itype_tgv) call tgv_listing() + if (itype == itype_tgv) call tgv_listing() - if (itype == itype_tgv2d) call tgv2d_listing() + if (itype == itype_tgv2d) call tgv2d_listing() - end subroutine case_listing + end subroutine case_listing - ! - ! Case-specific initialization - ! - subroutine case_init(ux1, uy1, uz1) + ! + ! Case-specific initialization + ! + subroutine case_init(ux1, uy1, uz1) - implicit none + implicit none - ! Arguments - real(mytype),intent(out),dimension(xsize(1),xsize(2),xsize(3)) :: ux1, uy1, uz1 + ! Arguments + real(mytype), intent(out), dimension(xsize(1), xsize(2), xsize(3)) :: ux1, uy1, uz1 - if (itype == itype_tgv) call tgv_init(ux1, uy1, uz1) + if (itype == itype_tgv) call tgv_init(ux1, uy1, uz1) - if (itype == itype_tgv2d) call tgv2d_init(ux1, uy1, uz1) + if (itype == itype_tgv2d) call tgv2d_init(ux1, uy1, uz1) - end subroutine case_init + end subroutine case_init - ! - ! Case-specific boundary conditions - ! - subroutine case_bc(ux1, uy1, uz1) + ! + ! Case-specific boundary conditions + ! + subroutine case_bc(ux1, uy1, uz1) - implicit none + implicit none - ! Arguments - real(mytype), intent(inout), dimension(xsize(1),xsize(2),xsize(3)) :: ux1, uy1, uz1 + ! Arguments + real(mytype), intent(inout), dimension(xsize(1), xsize(2), xsize(3)) :: ux1, uy1, uz1 - end subroutine case_bc + end subroutine case_bc - ! - ! Add case-specific forcing term in the momentum r.h.s. - ! - subroutine case_forcing(dux1, duy1, duz1) + ! + ! Add case-specific forcing term in the momentum r.h.s. + ! + subroutine case_forcing(dux1, duy1, duz1) - use param, only : ntime + use param, only: ntime - implicit none + implicit none - ! Arguments - real(mytype), intent(inout), dimension(xsize(1),xsize(2),xsize(3),ntime) :: dux1, duy1, duz1 + ! Arguments + real(mytype), intent(inout), dimension(xsize(1), xsize(2), xsize(3), ntime) :: dux1, duy1, duz1 - end subroutine case_forcing + end subroutine case_forcing - ! - ! Visualization - ! This is called when itime % ioutput = 0 - ! - subroutine case_visu() + ! + ! Visualization + ! This is called when itime % ioutput = 0 + ! + subroutine case_visu() - implicit none + implicit none - end subroutine case_visu + end subroutine case_visu - ! - ! Case-specific post-processing - ! This is called at the end of each time step - ! - subroutine case_postprocess(ux1, uy1, uz1, ndt) + ! + ! Case-specific post-processing + ! This is called at the end of each time step + ! + subroutine case_postprocess(ux1, uy1, uz1, ndt) - use param, only : ivisu, ioutput + use param, only: ivisu, ioutput - implicit none + implicit none - ! Arguments - real(mytype), dimension(xsize(1),xsize(2),xsize(3)), intent(in) :: ux1, uy1, uz1 - integer, intent(in) :: ndt + ! Arguments + real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: ux1, uy1, uz1 + integer, intent(in) :: ndt - if (itype == itype_tgv) call tgv_postprocess(ux1, uy1, uz1, ndt) + if (itype == itype_tgv) call tgv_postprocess(ux1, uy1, uz1, ndt) - if (itype == itype_tgv2d) call tgv2d_postprocess(ux1, uy1, uz1, ndt) + if (itype == itype_tgv2d) call tgv2d_postprocess(ux1, uy1, uz1, ndt) - if ((ivisu /= 0).and.(ioutput /= 0)) then - if (mod(ndt, ioutput) == 0) call case_visu() - endif + if ((ivisu /= 0) .and. (ioutput /= 0)) then + if (mod(ndt, ioutput) == 0) call case_visu() + end if - end subroutine case_postprocess + end subroutine case_postprocess - ! - ! Finalize case-specific IO - ! Free memory - ! - subroutine case_finalize() + ! + ! Finalize case-specific IO + ! Free memory + ! + subroutine case_finalize() - implicit none + implicit none - if (itype == itype_tgv) call tgv_finalize() + if (itype == itype_tgv) call tgv_finalize() - if (itype == itype_tgv2d) call tgv2d_finalize() + if (itype == itype_tgv2d) call tgv2d_finalize() - end subroutine case_finalize + end subroutine case_finalize end module case diff --git a/src/module_param.f90 b/src/module_param.f90 index 3e83217..ce41446 100644 --- a/src/module_param.f90 +++ b/src/module_param.f90 @@ -3,153 +3,151 @@ !SPDX-License-Identifier: BSD 3-Clause module variables - !USE param - !USE var - use decomp_2d, only : mytype - - ! Boundary conditions : ncl = 2 --> Dirichlet - ! Boundary conditions : ncl = 1 --> Free-slip - ! Boundary conditions : ncl = 0 --> Periodic - ! l: power of 2,3,4,5 and 6 - ! if ncl = 1 or 2, --> n = 2l+ 1 - ! --> nm = n - 1 - ! --> m = n + 1 - ! If ncl = 0, --> n = 2*l - ! --> nm = n - ! --> m = n + 2 - !nstat = size arrays for statistic collection - !2-->every 2 mesh nodes - !4-->every 4 mesh nodes - !nvisu = size for visualization collection - !nprobe = size for probe collection (energy spectra) - - !Possible n points: 3 5 7 9 11 13 17 19 21 25 31 33 37 41 49 51 55 61 65 73 81 91 97 101 109 121 129 145 151 161 163 181 193 201 217 241 251 257 271 289 301 321 325 361 385 401 433 451 481 487 501 513 541 577 601 641 649 721 751 769 801 811 865 901 961 973 1001 1025 1081 1153 1201 1251 1281 1297 1351 1441 1459 1501 1537 1601 1621 1729 1801 1921 1945 2001 2049 2161 2251 2305 2401 2431 2501 2561 2593 2701 2881 2917 3001 3073 3201 3241 3457 3601 3751 3841 3889 4001 4051 4097 4321 4375 4501 4609 4801 4861 5001 5121 5185 5401 5761 5833 6001 6145 6251 6401 6481 6751 6913 7201 7291 7501 7681 7777 8001 8101 8193 8641 8749 9001 9217 9601 9721 enough - - integer :: nx,ny,nz,numscalar,p_row,p_col,nxm,nym,nzm,spinup_time - integer :: nstat=1,nvisu=1,nprobe=1,nlength=1 - - real(mytype), save, allocatable, dimension(:) :: sc,uset,cp,ri,group - real(mytype) :: nu0nu, cnu + !USE param + !USE var + use decomp_2d, only: mytype + + ! Boundary conditions : ncl = 2 --> Dirichlet + ! Boundary conditions : ncl = 1 --> Free-slip + ! Boundary conditions : ncl = 0 --> Periodic + ! l: power of 2,3,4,5 and 6 + ! if ncl = 1 or 2, --> n = 2l+ 1 + ! --> nm = n - 1 + ! --> m = n + 1 + ! If ncl = 0, --> n = 2*l + ! --> nm = n + ! --> m = n + 2 + !nstat = size arrays for statistic collection + !2-->every 2 mesh nodes + !4-->every 4 mesh nodes + !nvisu = size for visualization collection + !nprobe = size for probe collection (energy spectra) + + !Possible n points: 3 5 7 9 11 13 17 19 21 25 31 33 37 41 49 51 55 61 65 73 81 91 97 101 109 121 129 145 151 161 163 181 193 201 217 241 251 257 271 289 301 321 325 361 385 401 433 451 481 487 501 513 541 577 601 641 649 721 751 769 801 811 865 901 961 973 1001 1025 1081 1153 1201 1251 1281 1297 1351 1441 1459 1501 1537 1601 1621 1729 1801 1921 1945 2001 2049 2161 2251 2305 2401 2431 2501 2561 2593 2701 2881 2917 3001 3073 3201 3241 3457 3601 3751 3841 3889 4001 4051 4097 4321 4375 4501 4609 4801 4861 5001 5121 5185 5401 5761 5833 6001 6145 6251 6401 6481 6751 6913 7201 7291 7501 7681 7777 8001 8101 8193 8641 8749 9001 9217 9601 9721 enough + + integer :: nx, ny, nz, numscalar, p_row, p_col, nxm, nym, nzm, spinup_time + integer :: nstat = 1, nvisu = 1, nprobe = 1, nlength = 1 + + real(mytype), save, allocatable, dimension(:) :: sc, uset, cp, ri, group + real(mytype) :: nu0nu, cnu #ifndef DOUBLE_PREC - integer,parameter :: prec = 4 + integer, parameter :: prec = 4 #else #ifdef SAVE_SINGLE - integer,parameter :: prec = 4 + integer, parameter :: prec = 4 #else - integer,parameter :: prec = 8 + integer, parameter :: prec = 8 #endif #endif - !module filter - real(mytype),dimension(200) :: idata + !module filter + real(mytype), dimension(200) :: idata - real(mytype), save, allocatable, dimension(:,:) :: fisx,fivx - real(mytype), save, allocatable, dimension(:,:) :: fisy,fivy - real(mytype), save, allocatable, dimension(:,:) :: fisz,fivz + real(mytype), save, allocatable, dimension(:, :) :: fisx, fivx + real(mytype), save, allocatable, dimension(:, :) :: fisy, fivy + real(mytype), save, allocatable, dimension(:, :) :: fisz, fivz !! X3DIV - logical :: test_mode - - !O6SVV - real(mytype),allocatable,dimension(:) :: newsm,newtm,newsmt,newtmt - !real(mytype),allocatable,dimension(:) :: newrm,ttm,newrmt,ttmt - real(mytype),allocatable,dimension(:) :: newrm,newrmt - - !module pressure - real(mytype), save, allocatable, dimension(:,:) :: dpdyx1,dpdyxn,dpdzx1,dpdzxn - real(mytype), save, allocatable, dimension(:,:) :: dpdxy1,dpdxyn,dpdzy1,dpdzyn - real(mytype), save, allocatable, dimension(:,:) :: dpdxz1,dpdxzn,dpdyz1,dpdyzn - - !module waves - complex(mytype),allocatable,dimension(:) :: zkz,zk2,ezs - complex(mytype),allocatable,dimension(:) :: yky,yk2,eys - complex(mytype),allocatable,dimension(:) :: xkx,xk2,exs - - !module mesh - real(mytype),allocatable,dimension(:) :: ppy,pp2y,pp4y - real(mytype),allocatable,dimension(:) :: ppyi,pp2yi,pp4yi - real(mytype),allocatable,dimension(:) :: xp,xpi,yp,ypi,dyp,zp,zpi,del - real(mytype),allocatable,dimension(:) :: yeta,yetai - real(mytype) :: alpha,beta + logical :: test_mode + + !O6SVV + real(mytype), allocatable, dimension(:) :: newsm, newtm, newsmt, newtmt + !real(mytype),allocatable,dimension(:) :: newrm,ttm,newrmt,ttmt + real(mytype), allocatable, dimension(:) :: newrm, newrmt + + !module pressure + real(mytype), save, allocatable, dimension(:, :) :: dpdyx1, dpdyxn, dpdzx1, dpdzxn + real(mytype), save, allocatable, dimension(:, :) :: dpdxy1, dpdxyn, dpdzy1, dpdzyn + real(mytype), save, allocatable, dimension(:, :) :: dpdxz1, dpdxzn, dpdyz1, dpdyzn + + !module waves + complex(mytype), allocatable, dimension(:) :: zkz, zk2, ezs + complex(mytype), allocatable, dimension(:) :: yky, yk2, eys + complex(mytype), allocatable, dimension(:) :: xkx, xk2, exs + + !module mesh + real(mytype), allocatable, dimension(:) :: ppy, pp2y, pp4y + real(mytype), allocatable, dimension(:) :: ppyi, pp2yi, pp4yi + real(mytype), allocatable, dimension(:) :: xp, xpi, yp, ypi, dyp, zp, zpi, del + real(mytype), allocatable, dimension(:) :: yeta, yetai + real(mytype) :: alpha, beta end module variables !############################################################################ !############################################################################ module param - use decomp_2d, only : mytype - - integer :: nclx1,nclxn,ncly1,nclyn,nclz1,nclzn - integer :: nclxS1,nclxSn,nclyS1,nclySn,nclzS1,nclzSn - - !logical variable for boundary condition that is true in periodic case - !and false otherwise - logical :: nclx,ncly,nclz - - integer, parameter :: itype_user = 0 - integer, parameter :: itype_lockexch = 1 - integer, parameter :: itype_tgv = 2 - integer, parameter :: itype_channel = 3 - integer, parameter :: itype_hill = 4 - integer, parameter :: itype_cyl = 5 - integer, parameter :: itype_dbg = 6 - integer, parameter :: itype_mixlayer = 7 - integer, parameter :: itype_jet = 8 - integer, parameter :: itype_tbl = 9 - integer, parameter :: itype_tgv2d = 10 - integer, save :: itype - - integer :: cont_phi,itr,itime,itest,iprocessing - integer :: ifft,istret,iforc_entree,iturb - integer :: iin,itimescheme,iimplicit,ifirst,ilast,iles - integer :: ntime ! How many (sub)timestpeps do we need to store? - integer :: icheckpoint,irestart,idebmod,ioutput,imodulo2,idemarre,icommence,irecord - integer :: itime0 - integer :: iscalar,nxboite,istat,iread,iadvance_time,irotation,iibm - integer :: npif,izap - integer :: ivisu, ipost, initstat - real(mytype) :: xlx,yly,zlz,dx,dy,dz,dx2,dy2,dz2,t,xxk1,xxk2,t0 - real(mytype) :: dt,re,xnu,init_noise,inflow_noise,u1,u2,angle,anglex,angley - real(mytype) :: wrotation,ro - real(mytype) :: dens1, dens2 - + use decomp_2d, only: mytype + + integer :: nclx1, nclxn, ncly1, nclyn, nclz1, nclzn + integer :: nclxS1, nclxSn, nclyS1, nclySn, nclzS1, nclzSn + + !logical variable for boundary condition that is true in periodic case + !and false otherwise + logical :: nclx, ncly, nclz + + integer, parameter :: itype_user = 0 + integer, parameter :: itype_lockexch = 1 + integer, parameter :: itype_tgv = 2 + integer, parameter :: itype_channel = 3 + integer, parameter :: itype_hill = 4 + integer, parameter :: itype_cyl = 5 + integer, parameter :: itype_dbg = 6 + integer, parameter :: itype_mixlayer = 7 + integer, parameter :: itype_jet = 8 + integer, parameter :: itype_tbl = 9 + integer, parameter :: itype_tgv2d = 10 + integer, save :: itype + + integer :: cont_phi, itr, itime, itest, iprocessing + integer :: ifft, istret, iforc_entree, iturb + integer :: iin, itimescheme, iimplicit, ifirst, ilast, iles + integer :: ntime ! How many (sub)timestpeps do we need to store? + integer :: icheckpoint, irestart, idebmod, ioutput, imodulo2, idemarre, icommence, irecord + integer :: itime0 + integer :: iscalar, nxboite, istat, iread, iadvance_time, irotation, iibm + integer :: npif, izap + integer :: ivisu, ipost, initstat + real(mytype) :: xlx, yly, zlz, dx, dy, dz, dx2, dy2, dz2, t, xxk1, xxk2, t0 + real(mytype) :: dt, re, xnu, init_noise, inflow_noise, u1, u2, angle, anglex, angley + real(mytype) :: wrotation, ro + real(mytype) :: dens1, dens2 !! Numerics control - integer :: ifirstder,isecondder,ipinter + integer :: ifirstder, isecondder, ipinter !! CFL_diffusion parameter - real(mytype) :: cfl_diff_x,cfl_diff_y,cfl_diff_z,cfl_diff_sum + real(mytype) :: cfl_diff_x, cfl_diff_y, cfl_diff_z, cfl_diff_sum !! - real(mytype) :: xcst - real(mytype), allocatable, dimension(:) :: xcst_sc - real(mytype), allocatable, dimension(:,:) :: alpha_sc, beta_sc, g_sc - real(mytype) :: g_bl_inf, f_bl_inf - - - integer :: npress - real(mytype), dimension(5) :: adt,bdt,cdt,ddt,gdt - !numbers - - real(mytype),parameter :: half=0.5_mytype - real(mytype),parameter :: twothird=2._mytype/3._mytype - real(mytype),parameter :: zero=0._mytype - real(mytype),parameter :: one=1._mytype - real(mytype),parameter :: onepfive=1.5_mytype - real(mytype),parameter :: two=2._mytype - real(mytype),parameter :: twopfive=2.5_mytype - real(mytype),parameter :: three=3._mytype - real(mytype),parameter :: threepfive=3.5_mytype - real(mytype),parameter :: four=4._mytype - real(mytype),parameter :: five=5._mytype - real(mytype),parameter :: six=6._mytype - real(mytype),parameter :: seven=7._mytype - real(mytype),parameter :: eight=8._mytype - real(mytype),parameter :: nine=9._mytype - real(mytype),parameter :: ten=10._mytype - - complex(mytype),parameter :: cx_one_one=cmplx(one, one, kind=mytype) + real(mytype) :: xcst + real(mytype), allocatable, dimension(:) :: xcst_sc + real(mytype), allocatable, dimension(:, :) :: alpha_sc, beta_sc, g_sc + real(mytype) :: g_bl_inf, f_bl_inf + + integer :: npress + real(mytype), dimension(5) :: adt, bdt, cdt, ddt, gdt + !numbers + + real(mytype), parameter :: half = 0.5_mytype + real(mytype), parameter :: twothird = 2._mytype/3._mytype + real(mytype), parameter :: zero = 0._mytype + real(mytype), parameter :: one = 1._mytype + real(mytype), parameter :: onepfive = 1.5_mytype + real(mytype), parameter :: two = 2._mytype + real(mytype), parameter :: twopfive = 2.5_mytype + real(mytype), parameter :: three = 3._mytype + real(mytype), parameter :: threepfive = 3.5_mytype + real(mytype), parameter :: four = 4._mytype + real(mytype), parameter :: five = 5._mytype + real(mytype), parameter :: six = 6._mytype + real(mytype), parameter :: seven = 7._mytype + real(mytype), parameter :: eight = 8._mytype + real(mytype), parameter :: nine = 9._mytype + real(mytype), parameter :: ten = 10._mytype + + complex(mytype), parameter :: cx_one_one = cmplx(one, one, kind=mytype) end module param !############################################################################ diff --git a/src/navier.f90 b/src/navier.f90 index 18c9076..ac5277e 100644 --- a/src/navier.f90 +++ b/src/navier.f90 @@ -4,286 +4,284 @@ module navier - implicit none + implicit none - private + private - public :: solve_poisson, divergence - public :: cor_vel - public :: gradp + public :: solve_poisson, divergence + public :: cor_vel + public :: gradp contains - !############################################################################ + !############################################################################ !! SUBROUTINE: solve_poisson !! DESCRIPTION: Takes the intermediate momentum field as input, !! computes div and solves pressure-Poisson equation. - !############################################################################ - SUBROUTINE solve_poisson(pp3, px1, py1, pz1, ux1, uy1, uz1) + !############################################################################ + SUBROUTINE solve_poisson(pp3, px1, py1, pz1, ux1, uy1, uz1) - use decomp_2d, only : mytype - USE decomp_2d, ONLY : xsize, zsize, ph1 - USE decomp_2d_poisson, ONLY : poisson - USE variables, ONLY : nzm - USE param, ONLY : npress + use decomp_2d, only: mytype + USE decomp_2d, ONLY: xsize, zsize, ph1 + USE decomp_2d_poisson, ONLY: poisson + USE variables, ONLY: nzm + USE param, ONLY: npress - implicit none + implicit none !! Inputs - REAL(mytype), DIMENSION(xsize(1), xsize(2), xsize(3)), INTENT(IN) :: ux1, uy1, uz1 + REAL(mytype), DIMENSION(xsize(1), xsize(2), xsize(3)), INTENT(IN) :: ux1, uy1, uz1 !! Outputs - REAL(mytype), DIMENSION(ph1%zst(1):ph1%zen(1), ph1%zst(2):ph1%zen(2), nzm, npress) :: pp3 - REAL(mytype), DIMENSION(xsize(1), xsize(2), xsize(3)) :: px1, py1, pz1 + REAL(mytype), DIMENSION(ph1%zst(1):ph1%zen(1), ph1%zst(2):ph1%zen(2), nzm, npress) :: pp3 + REAL(mytype), DIMENSION(xsize(1), xsize(2), xsize(3)) :: px1, py1, pz1 !! Locals - INTEGER :: nlock - - nlock = 1 !! Corresponds to computing div(u*) - - CALL divergence(pp3(:,:,:,1),ux1,uy1,uz1,nlock) - ! - CALL poisson(pp3(:,:,:,1)) - ! - CALL gradp(px1,py1,pz1,pp3(:,:,:,1)) - - END SUBROUTINE solve_poisson - !############################################################################ - !subroutine COR_VEL - !Correction of u* by the pressure gradient to get a divergence free - !field - ! input : px,py,pz - ! output : ux,uy,uz - !############################################################################ - subroutine cor_vel (ux,uy,uz,px,py,pz) - - use decomp_2d, only : mytype - use decomp_2d, only : xsize - USE variables - USE param - - implicit none - - integer :: i,j,k - - real(mytype),dimension(xsize(1),xsize(2),xsize(3)) :: ux,uy,uz - real(mytype),dimension(xsize(1),xsize(2),xsize(3)),intent(in) :: px,py,pz - - do concurrent (k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) - ux(i,j,k)=ux(i,j,k)-px(i,j,k) - uy(i,j,k)=uy(i,j,k)-py(i,j,k) - uz(i,j,k)=uz(i,j,k)-pz(i,j,k) - enddo - - return - end subroutine cor_vel - !############################################################################ - !subroutine DIVERGENCe - !Calculation of div u* for nlock=1 and of div u^{n+1} for nlock=2 - ! input : ux1,uy1,uz1,ep1 (on velocity mesh) - ! output : pp3 (on pressure mesh) - !############################################################################ - subroutine divergence (pp3,ux1,uy1,uz1,nlock) - - use x3d_operator_1d - use x3d_staggered - use decomp_2d, only : mytype, real_type, decomp_2d_warning - use param - use decomp_2d, only : nrank, ph1, ph2, ph3, nproc - use decomp_2d, only : xsize, ysize, zsize - use decomp_2d, only : nx_global, ny_global, nz_global - use decomp_2d, only : transpose_x_to_y, & - transpose_y_to_z, & - transpose_z_to_y, & - transpose_y_to_x - USE variables - USE var, ONLY: ta1, tb1, tc1, pp1, pgy1, pgz1, & - duxdxp2, uyp2, uzp2, duydypi2, upi2, ta2, & - duxydxyp3, uzp3, po3 - USE MPI - - implicit none - - - !X PENCILS NX NY NZ -->NXM NY NZ - real(mytype),dimension(xsize(1),xsize(2),xsize(3)),intent(in) :: ux1,uy1,uz1 - !Z PENCILS NXM NYM NZ -->NXM NYM NZM - real(mytype),dimension(ph1%zst(1):ph1%zen(1),ph1%zst(2):ph1%zen(2),nzm) :: pp3 - - integer :: nvect3,i,j,k,nlock - integer :: code - real(mytype) :: tmax,tmoy,tmax1,tmoy1 - - nvect3=(ph1%zen(1)-ph1%zst(1)+1)*(ph1%zen(2)-ph1%zst(2)+1)*nzm - - do concurrent (k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) - ta1(i,j,k) = ux1(i,j,k) - tb1(i,j,k) = uy1(i,j,k) - tc1(i,j,k) = uz1(i,j,k) - enddo - - !WORK X-PENCILS - - - call derxvp(pp1,ta1,x3d_op_derxvp,xsize(1),nxm,xsize(2),xsize(3)) - - call interxvp(pgy1,tb1,x3d_op_intxvp,xsize(1),nxm,xsize(2),xsize(3)) - call interxvp(pgz1,tc1,x3d_op_intxvp,xsize(1),nxm,xsize(2),xsize(3)) - - call transpose_x_to_y(pp1,duxdxp2,ph2)!->NXM NY NZ - call transpose_x_to_y(pgy1,uyp2,ph2) - call transpose_x_to_y(pgz1,uzp2,ph2) - - !WORK Y-PENCILS - call interyvp(upi2,duxdxp2,x3d_op_intyvp,(ph1%yen(1)-ph1%yst(1)+1),ysize(2),nym,ysize(3)) - call deryvp(duydypi2,uyp2,x3d_op_deryvp,ppyi,(ph1%yen(1)-ph1%yst(1)+1),ysize(2),nym,ysize(3)) + INTEGER :: nlock + + nlock = 1 !! Corresponds to computing div(u*) + + CALL divergence(pp3(:, :, :, 1), ux1, uy1, uz1, nlock) + ! + CALL poisson(pp3(:, :, :, 1)) + ! + CALL gradp(px1, py1, pz1, pp3(:, :, :, 1)) + + END SUBROUTINE solve_poisson + !############################################################################ + !subroutine COR_VEL + !Correction of u* by the pressure gradient to get a divergence free + !field + ! input : px,py,pz + ! output : ux,uy,uz + !############################################################################ + subroutine cor_vel(ux, uy, uz, px, py, pz) + + use decomp_2d, only: mytype + use decomp_2d, only: xsize + USE variables + USE param + + implicit none + + integer :: i, j, k + + real(mytype), dimension(xsize(1), xsize(2), xsize(3)) :: ux, uy, uz + real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: px, py, pz + + do concurrent(k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) + ux(i, j, k) = ux(i, j, k) - px(i, j, k) + uy(i, j, k) = uy(i, j, k) - py(i, j, k) + uz(i, j, k) = uz(i, j, k) - pz(i, j, k) + end do + + return + end subroutine cor_vel + !############################################################################ + !subroutine DIVERGENCe + !Calculation of div u* for nlock=1 and of div u^{n+1} for nlock=2 + ! input : ux1,uy1,uz1,ep1 (on velocity mesh) + ! output : pp3 (on pressure mesh) + !############################################################################ + subroutine divergence(pp3, ux1, uy1, uz1, nlock) + + use x3d_operator_1d + use x3d_staggered + use decomp_2d, only: mytype, real_type, decomp_2d_warning + use param + use decomp_2d, only: nrank, ph1, ph2, ph3, nproc + use decomp_2d, only: xsize, ysize, zsize + use decomp_2d, only: nx_global, ny_global, nz_global + use decomp_2d, only: transpose_x_to_y, & + transpose_y_to_z, & + transpose_z_to_y, & + transpose_y_to_x + USE variables + USE var, ONLY: ta1, tb1, tc1, pp1, pgy1, pgz1, & + duxdxp2, uyp2, uzp2, duydypi2, upi2, ta2, & + duxydxyp3, uzp3, po3 + USE MPI + + implicit none + + !X PENCILS NX NY NZ -->NXM NY NZ + real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: ux1, uy1, uz1 + !Z PENCILS NXM NYM NZ -->NXM NYM NZM + real(mytype), dimension(ph1%zst(1):ph1%zen(1), ph1%zst(2):ph1%zen(2), nzm) :: pp3 + + integer :: nvect3, i, j, k, nlock + integer :: code + real(mytype) :: tmax, tmoy, tmax1, tmoy1 + + nvect3 = (ph1%zen(1) - ph1%zst(1) + 1)*(ph1%zen(2) - ph1%zst(2) + 1)*nzm + + do concurrent(k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) + ta1(i, j, k) = ux1(i, j, k) + tb1(i, j, k) = uy1(i, j, k) + tc1(i, j, k) = uz1(i, j, k) + end do + + !WORK X-PENCILS + + call derxvp(pp1, ta1, x3d_op_derxvp, xsize(1), nxm, xsize(2), xsize(3)) + + call interxvp(pgy1, tb1, x3d_op_intxvp, xsize(1), nxm, xsize(2), xsize(3)) + call interxvp(pgz1, tc1, x3d_op_intxvp, xsize(1), nxm, xsize(2), xsize(3)) + + call transpose_x_to_y(pp1, duxdxp2, ph2)!->NXM NY NZ + call transpose_x_to_y(pgy1, uyp2, ph2) + call transpose_x_to_y(pgz1, uzp2, ph2) + + !WORK Y-PENCILS + call interyvp(upi2, duxdxp2, x3d_op_intyvp, (ph1%yen(1) - ph1%yst(1) + 1), ysize(2), nym, ysize(3)) + call deryvp(duydypi2, uyp2, x3d_op_deryvp, ppyi, (ph1%yen(1) - ph1%yst(1) + 1), ysize(2), nym, ysize(3)) !! Compute sum dudx + dvdy !ph1%yst(1):ph1%yen(1),nym,ysize(3) - do concurrent (k=1:ysize(3), j=1:nym, i=ph1%yst(1):ph1%yen(1)) - duydypi2(i,j,k) = duydypi2(i,j,k) + upi2(i,j,k) - enddo + do concurrent(k=1:ysize(3), j=1:nym, i=ph1%yst(1):ph1%yen(1)) + duydypi2(i, j, k) = duydypi2(i, j, k) + upi2(i, j, k) + end do - call interyvp(upi2,uzp2,x3d_op_intyvp,(ph1%yen(1)-ph1%yst(1)+1),ysize(2),nym,ysize(3)) + call interyvp(upi2, uzp2, x3d_op_intyvp, (ph1%yen(1) - ph1%yst(1) + 1), ysize(2), nym, ysize(3)) - call transpose_y_to_z(duydypi2,duxydxyp3,ph3)!->NXM NYM NZ - call transpose_y_to_z(upi2,uzp3,ph3) + call transpose_y_to_z(duydypi2, duxydxyp3, ph3)!->NXM NYM NZ + call transpose_y_to_z(upi2, uzp3, ph3) - !WORK Z-PENCILS - call interzvp(pp3,duxydxyp3,x3d_op_intzvp,(ph1%zen(1)-ph1%zst(1)+1),& - (ph1%zen(2)-ph1%zst(2)+1),zsize(3),nzm) - call derzvp(po3,uzp3,x3d_op_derzvp,(ph1%zen(1)-ph1%zst(1)+1),& - (ph1%zen(2)-ph1%zst(2)+1),zsize(3),nzm) + !WORK Z-PENCILS + call interzvp(pp3, duxydxyp3, x3d_op_intzvp, (ph1%zen(1) - ph1%zst(1) + 1), & + (ph1%zen(2) - ph1%zst(2) + 1), zsize(3), nzm) + call derzvp(po3, uzp3, x3d_op_derzvp, (ph1%zen(1) - ph1%zst(1) + 1), & + (ph1%zen(2) - ph1%zst(2) + 1), zsize(3), nzm) !! Compute sum dudx + dvdy + dwdz - do concurrent (k=1:nzm, j=ph1%zst(2):ph1%zen(2), i=ph1%zst(1):ph1%zen(1)) - pp3(i,j,k) = pp3(i,j,k) + po3(i,j,k) - enddo - - tmax = maxval(abs(pp3)) - tmoy = sum(abs(pp3)) / nvect3 - - call MPI_REDUCE(tmax,tmax1,1,real_type,MPI_MAX,0,MPI_COMM_WORLD,code) - if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_REDUCE") - call MPI_REDUCE(tmoy,tmoy1,1,real_type,MPI_SUM,0,MPI_COMM_WORLD,code) - if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_REDUCE") - - if ((nrank==0).and.(nlock.gt.0)) then - if (nlock==2) then - print *,'DIV U max mean=', tmax1, tmoy1 - else - print *,'DIV U* max mean=', tmax1, tmoy1 - endif - endif - - return - end subroutine divergence - !############################################################################ - !subroutine GRADP - !Computation of the pressure gradient from the pressure mesh to the - !velocity mesh - !Saving pressure gradients on boundaries for correct imposition of - !BCs on u* via the fractional step methodi (it is not possible to - !impose BC after correction by pressure gradient otherwise lost of - !incompressibility--> BCs are imposed on u* - ! - ! input: pp3 - pressure field (on pressure mesh) - ! output: px1, py1, pz1 - pressure gradients (on velocity mesh) - !############################################################################ - subroutine gradp(px1,py1,pz1,pp3) - - use x3d_operator_1d - use x3d_staggered - use x3d_transpose - USE param - USE decomp_2d, only: mytype, xsize, ysize, zsize, ph2, ph3 - use decomp_2d, only: xstart, xend, ystart, yend, zstart, zend - USE variables - USE var, only: pp1,pgy1,pgz1,pp2,ppi2,pgy2,pgz2,pgzi2,& - pgz3,ppi3 - - implicit none - - integer :: i,j,k - - real(mytype),dimension(ph3%zst(1):ph3%zen(1),ph3%zst(2):ph3%zen(2),nzm) :: pp3 - real(mytype),dimension(xsize(1),xsize(2),xsize(3)) :: px1,py1,pz1 - - !WORK Z-PENCILS - call interzpv(ppi3,pp3,x3d_op_intzpv,& - (ph3%zen(1)-ph3%zst(1)+1),(ph3%zen(2)-ph3%zst(2)+1),nzm,zsize(3)) - call derzpv(pgz3,pp3,x3d_op_derzpv,& - (ph3%zen(1)-ph3%zst(1)+1),(ph3%zen(2)-ph3%zst(2)+1),nzm,zsize(3)) - - !WORK Y-PENCILS - call x3d_transpose_z_to_y(pgz3,pgz2,ph3) !nxm nym nz - call x3d_transpose_z_to_y(ppi3,pp2,ph3) - - call interypv(ppi2,pp2,x3d_op_intypv,& - (ph3%yen(1)-ph3%yst(1)+1),nym,ysize(2),ysize(3)) - call derypv(pgy2,pp2,x3d_op_derypv,ppy,& - (ph3%yen(1)-ph3%yst(1)+1),nym,ysize(2),ysize(3)) - call interypv(pgzi2,pgz2,x3d_op_intypv,& - (ph3%yen(1)-ph3%yst(1)+1),nym,ysize(2),ysize(3)) - - !WORK X-PENCILS - - call x3d_transpose_y_to_x(ppi2,pp1,ph2) !nxm ny nz - call x3d_transpose_y_to_x(pgy2,pgy1,ph2) - call x3d_transpose_y_to_x(pgzi2,pgz1,ph2) - - call derxpv(px1,pp1,x3d_op_derxpv,nxm,xsize(1),xsize(2),xsize(3)) - call interxpv(py1,pgy1,x3d_op_intxpv,nxm,xsize(1),xsize(2),xsize(3)) - call interxpv(pz1,pgz1,x3d_op_intxpv,nxm,xsize(1),xsize(2),xsize(3)) - - !we are in X pencils: - if (nclx1.eq.2) then - do concurrent (k=1:xsize(3),j=1:xsize(2)) - dpdyx1(j,k)=py1(1,j,k)/gdt(itr) - dpdzx1(j,k)=pz1(1,j,k)/gdt(itr) - enddo - endif - if (nclxn.eq.2) then - do concurrent (k=1:xsize(3),j=1:xsize(2)) - dpdyxn(j,k)=py1(nx,j,k)/gdt(itr) - dpdzxn(j,k)=pz1(nx,j,k)/gdt(itr) - enddo - endif - - if (ncly1.eq.2) then - if (xstart(2)==1) then - do concurrent (k=1:xsize(3),i=1:xsize(1)) - dpdxy1(i,k)=px1(i,1,k)/gdt(itr) - dpdzy1(i,k)=pz1(i,1,k)/gdt(itr) - enddo - endif - endif - if (nclyn.eq.2) then - if (xend(2)==ny) then - do concurrent (k=1:xsize(3),i=1:xsize(1)) - dpdxyn(i,k)=px1(i,xsize(2),k)/gdt(itr) - dpdzyn(i,k)=pz1(i,xsize(2),k)/gdt(itr) - enddo - endif - endif - - if (nclz1.eq.2) then - if (xstart(3)==1) then - do concurrent (j=1:xsize(2),i=1:xsize(1)) - dpdxz1(i,j)=py1(i,j,1)/gdt(itr) - dpdyz1(i,j)=pz1(i,j,1)/gdt(itr) - enddo - endif - endif - if (nclzn.eq.2) then - if (xend(3)==nz) then - do concurrent (j=1:xsize(2),i=1:xsize(1)) - dpdxzn(i,j)=py1(i,j,xsize(3))/gdt(itr) - dpdyzn(i,j)=pz1(i,j,xsize(3))/gdt(itr) - enddo - endif - endif - - return - end subroutine gradp - !############################################################################ - !############################################################################ -endmodule navier + do concurrent(k=1:nzm, j=ph1%zst(2):ph1%zen(2), i=ph1%zst(1):ph1%zen(1)) + pp3(i, j, k) = pp3(i, j, k) + po3(i, j, k) + end do + + tmax = maxval(abs(pp3)) + tmoy = sum(abs(pp3))/nvect3 + + call MPI_REDUCE(tmax, tmax1, 1, real_type, MPI_MAX, 0, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_REDUCE") + call MPI_REDUCE(tmoy, tmoy1, 1, real_type, MPI_SUM, 0, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_REDUCE") + + if ((nrank == 0) .and. (nlock > 0)) then + if (nlock == 2) then + print *, 'DIV U max mean=', tmax1, tmoy1 + else + print *, 'DIV U* max mean=', tmax1, tmoy1 + end if + end if + + return + end subroutine divergence + !############################################################################ + !subroutine GRADP + !Computation of the pressure gradient from the pressure mesh to the + !velocity mesh + !Saving pressure gradients on boundaries for correct imposition of + !BCs on u* via the fractional step methodi (it is not possible to + !impose BC after correction by pressure gradient otherwise lost of + !incompressibility--> BCs are imposed on u* + ! + ! input: pp3 - pressure field (on pressure mesh) + ! output: px1, py1, pz1 - pressure gradients (on velocity mesh) + !############################################################################ + subroutine gradp(px1, py1, pz1, pp3) + + use x3d_operator_1d + use x3d_staggered + use x3d_transpose + USE param + USE decomp_2d, only: mytype, xsize, ysize, zsize, ph2, ph3 + use decomp_2d, only: xstart, xend, ystart, yend, zstart, zend + USE variables + USE var, only: pp1, pgy1, pgz1, pp2, ppi2, pgy2, pgz2, pgzi2, & + pgz3, ppi3 + + implicit none + + integer :: i, j, k + + real(mytype), dimension(ph3%zst(1):ph3%zen(1), ph3%zst(2):ph3%zen(2), nzm) :: pp3 + real(mytype), dimension(xsize(1), xsize(2), xsize(3)) :: px1, py1, pz1 + + !WORK Z-PENCILS + call interzpv(ppi3, pp3, x3d_op_intzpv, & + (ph3%zen(1) - ph3%zst(1) + 1), (ph3%zen(2) - ph3%zst(2) + 1), nzm, zsize(3)) + call derzpv(pgz3, pp3, x3d_op_derzpv, & + (ph3%zen(1) - ph3%zst(1) + 1), (ph3%zen(2) - ph3%zst(2) + 1), nzm, zsize(3)) + + !WORK Y-PENCILS + call x3d_transpose_z_to_y(pgz3, pgz2, ph3) !nxm nym nz + call x3d_transpose_z_to_y(ppi3, pp2, ph3) + + call interypv(ppi2, pp2, x3d_op_intypv, & + (ph3%yen(1) - ph3%yst(1) + 1), nym, ysize(2), ysize(3)) + call derypv(pgy2, pp2, x3d_op_derypv, ppy, & + (ph3%yen(1) - ph3%yst(1) + 1), nym, ysize(2), ysize(3)) + call interypv(pgzi2, pgz2, x3d_op_intypv, & + (ph3%yen(1) - ph3%yst(1) + 1), nym, ysize(2), ysize(3)) + + !WORK X-PENCILS + + call x3d_transpose_y_to_x(ppi2, pp1, ph2) !nxm ny nz + call x3d_transpose_y_to_x(pgy2, pgy1, ph2) + call x3d_transpose_y_to_x(pgzi2, pgz1, ph2) + + call derxpv(px1, pp1, x3d_op_derxpv, nxm, xsize(1), xsize(2), xsize(3)) + call interxpv(py1, pgy1, x3d_op_intxpv, nxm, xsize(1), xsize(2), xsize(3)) + call interxpv(pz1, pgz1, x3d_op_intxpv, nxm, xsize(1), xsize(2), xsize(3)) + + !we are in X pencils: + if (nclx1 == 2) then + do concurrent(k=1:xsize(3), j=1:xsize(2)) + dpdyx1(j, k) = py1(1, j, k)/gdt(itr) + dpdzx1(j, k) = pz1(1, j, k)/gdt(itr) + end do + end if + if (nclxn == 2) then + do concurrent(k=1:xsize(3), j=1:xsize(2)) + dpdyxn(j, k) = py1(nx, j, k)/gdt(itr) + dpdzxn(j, k) = pz1(nx, j, k)/gdt(itr) + end do + end if + + if (ncly1 == 2) then + if (xstart(2) == 1) then + do concurrent(k=1:xsize(3), i=1:xsize(1)) + dpdxy1(i, k) = px1(i, 1, k)/gdt(itr) + dpdzy1(i, k) = pz1(i, 1, k)/gdt(itr) + end do + end if + end if + if (nclyn == 2) then + if (xend(2) == ny) then + do concurrent(k=1:xsize(3), i=1:xsize(1)) + dpdxyn(i, k) = px1(i, xsize(2), k)/gdt(itr) + dpdzyn(i, k) = pz1(i, xsize(2), k)/gdt(itr) + end do + end if + end if + + if (nclz1 == 2) then + if (xstart(3) == 1) then + do concurrent(j=1:xsize(2), i=1:xsize(1)) + dpdxz1(i, j) = py1(i, j, 1)/gdt(itr) + dpdyz1(i, j) = pz1(i, j, 1)/gdt(itr) + end do + end if + end if + if (nclzn == 2) then + if (xend(3) == nz) then + do concurrent(j=1:xsize(2), i=1:xsize(1)) + dpdxzn(i, j) = py1(i, j, xsize(3))/gdt(itr) + dpdyzn(i, j) = pz1(i, j, xsize(3))/gdt(itr) + end do + end if + end if + + return + end subroutine gradp + !############################################################################ + !############################################################################ +end module navier diff --git a/src/parameters.f90 b/src/parameters.f90 index 07bad61..ab70488 100644 --- a/src/parameters.f90 +++ b/src/parameters.f90 @@ -4,11 +4,11 @@ module parameters - use decomp_2d, only : mytype, nrank, nproc, decomp_2d_abort - use param - use variables + use decomp_2d, only: mytype, nrank, nproc, decomp_2d_abort + use param + use variables - private :: parameter_defaults + private :: parameter_defaults contains @@ -20,73 +20,73 @@ module parameters ! FIXME : Only rank=0 should read input.i3d, then MPI_BCAST ! !########################################################################### -subroutine parameter() + subroutine parameter() - use x3d_precision, only : pi + use x3d_precision, only: pi - implicit none + implicit none - integer :: longueur ,impi,j, is, total + integer :: longueur, impi, j, is, total #ifdef DEBUG - if (nrank == 0) write(*,*) '# parameter start' + if (nrank == 0) write (*, *) '# parameter start' #endif - call parameter_defaults() - - if (nz==1) then - nclz1 = 0 - nclzn = 0 - p_row = nproc - p_col = 1 - endif - - !! Set Scalar BCs same as fluid (may be overridden) [DEFAULT] - nclxS1 = nclx1; nclxSn = nclxn - nclyS1 = ncly1; nclySn = nclyn - nclzS1 = nclz1; nclzSn = nclzn - nu0nu=four - cnu=0.44_mytype - - if (nclx1.eq.0.and.nclxn.eq.0) then - nclx=.true. - nxm=nx - else - nclx=.false. - nxm=nx-1 - endif - if (ncly1.eq.0.and.nclyn.eq.0) then - ncly=.true. - nym=ny - else - ncly=.false. - nym=ny-1 - endif - if (nclz1.eq.0.and.nclzn.eq.0) then - nclz=.true. - nzm=nz - else - nclz=.false. - nzm=nz-1 - endif - - dx=xlx/real(nxm,mytype) - dy=yly/real(nym,mytype) - dz=zlz/real(nzm,mytype) - - dx2 = dx * dx - dy2 = dy * dy - dz2 = dz * dz - - if (abs(re) > epsilon(re)) then - xnu = one / re - else - xnu = zero - endif - - ! Some safety check - if (itimescheme > 1) call decomp_2d_abort(itimescheme, "itimescheme must be specified as 1-6") - -end subroutine parameter + call parameter_defaults() + + if (nz == 1) then + nclz1 = 0 + nclzn = 0 + p_row = nproc + p_col = 1 + end if + + ! Set Scalar BCs same as fluid (may be overridden) [DEFAULT] + nclxS1 = nclx1; nclxSn = nclxn + nclyS1 = ncly1; nclySn = nclyn + nclzS1 = nclz1; nclzSn = nclzn + nu0nu = four + cnu = 0.44_mytype + + if (nclx1 == 0 .and. nclxn == 0) then + nclx = .true. + nxm = nx + else + nclx = .false. + nxm = nx - 1 + end if + if (ncly1 == 0 .and. nclyn == 0) then + ncly = .true. + nym = ny + else + ncly = .false. + nym = ny - 1 + end if + if (nclz1 == 0 .and. nclzn == 0) then + nclz = .true. + nzm = nz + else + nclz = .false. + nzm = nz - 1 + end if + + dx = xlx/real(nxm, mytype) + dy = yly/real(nym, mytype) + dz = zlz/real(nzm, mytype) + + dx2 = dx*dx + dy2 = dy*dy + dz2 = dz*dz + + if (abs(re) > epsilon(re)) then + xnu = one/re + else + xnu = zero + end if + + ! Some safety check + if (itimescheme > 1) call decomp_2d_abort(itimescheme, "itimescheme must be specified as 1-6") + + end subroutine parameter !########################################################################### ! @@ -94,136 +94,136 @@ end subroutine parameter ! DESCRIPTION: Sets the default simulation parameters. ! !########################################################################### -subroutine parameter_defaults() - - use x3d_precision, only : twopi - - implicit none - - integer :: i - - ifirstder = 4 - isecondder = 4 - ro = 99999999._mytype - angle = zero - u1 = 2 - u2 = 1 - init_noise = zero - inflow_noise = zero - iin = 0 - itimescheme = 1 - iimplicit = 0 - istret = 0 - ipinter=3 - beta = 0 - iscalar = 0 - cont_phi = 0 - irestart = 0 - itime0 = 0 - t0 = zero - dt = zero - - nclx1 = 0; nclxn = 0 - ncly1 = 0; nclyn = 0 - nclz1 = 0; nclzn = 0 - - npress = 1 !! By default people only need one pressure field - imodulo2 = 1 - - itype = itype_tgv - ivisu = 0 - ioutput = 0 - -end subroutine parameter_defaults + subroutine parameter_defaults() + + use x3d_precision, only: twopi + + implicit none + + integer :: i + + ifirstder = 4 + isecondder = 4 + ro = 99999999._mytype + angle = zero + u1 = 2 + u2 = 1 + init_noise = zero + inflow_noise = zero + iin = 0 + itimescheme = 1 + iimplicit = 0 + istret = 0 + ipinter = 3 + beta = 0 + iscalar = 0 + cont_phi = 0 + irestart = 0 + itime0 = 0 + t0 = zero + dt = zero + + nclx1 = 0; nclxn = 0 + ncly1 = 0; nclyn = 0 + nclz1 = 0; nclzn = 0 + + npress = 1 ! By default people only need one pressure field + imodulo2 = 1 + + itype = itype_tgv + ivisu = 0 + ioutput = 0 + + end subroutine parameter_defaults ! ! Log / output ! -subroutine listing() + subroutine listing() - use MPI - use iso_fortran_env + use MPI + use iso_fortran_env - implicit none + implicit none - if (nrank==0) then - write(*,*) '===========================================================' - write(*,*) '======================Xcompact3D===========================' - write(*,*) '===Copyright (c) 2022 Éric Lamballais and Sylvain Laizet===' - write(*,*) '===========================================================' + if (nrank == 0) then + write (*, *) '===========================================================' + write (*, *) '======================Xcompact3D===========================' + write (*, *) '===Copyright (c) 2022 Éric Lamballais and Sylvain Laizet===' + write (*, *) '===========================================================' #if defined(VERSION) - write(*,*)'Git version : ', VERSION + write (*, *) 'Git version : ', VERSION #else - write(*,*)'Git version : unknown' + write (*, *) 'Git version : unknown' #endif - write(*,"(' Reynolds number Re : ',F17.3)") re - write(*,"(' xnu : ',F17.8)") xnu - print *,'===========================================================' - write(*,"(' p_row, p_col : ',I9, I8)") p_row, p_col - print *,'===========================================================' - write(*,"(' Time step dt : ',F17.8)") dt - ! - if (itimescheme.eq.1) then - write(*,"(' Temporal scheme : ',A20)") "Forwards Euler" - else - print *,'Error: itimescheme must be specified as 1-6' - stop - endif - ! - write(*,*)'===========================================================' - write(*,"(' ifirst : ',I17)") ifirst - write(*,"(' ilast : ',I17)") ilast - write(*,*)'===========================================================' - write(*,"(' Lx : ',F17.8)") xlx - write(*,"(' Ly : ',F17.8)") yly - write(*,"(' Lz : ',F17.8)") zlz - write(*,"(' nx : ',I17)") nx - write(*,"(' ny : ',I17)") ny - write(*,"(' nz : ',I17)") nz - write(*,*)'===========================================================' - write(*,"(' nu0nu : ',F17.8)") nu0nu - write(*,"(' cnu : ',F17.8)") cnu - write(*,*)'===========================================================' - write(*,"(' High and low speed : u1=',F6.2,' and u2=',F6.2)") u1,u2 - write(*,*)'===========================================================' - ! Show the compile flags detected and the version of the MPI library + write (*, "(' Reynolds number Re : ',F17.3)") re + write (*, "(' xnu : ',F17.8)") xnu + print *, '===========================================================' + write (*, "(' p_row, p_col : ',I9, I8)") p_row, p_col + print *, '===========================================================' + write (*, "(' Time step dt : ',F17.8)") dt + ! + if (itimescheme == 1) then + write (*, "(' Temporal scheme : ',A20)") "Forwards Euler" + else + print *, 'Error: itimescheme must be specified as 1-6' + stop + end if + ! + write (*, *) '===========================================================' + write (*, "(' ifirst : ',I17)") ifirst + write (*, "(' ilast : ',I17)") ilast + write (*, *) '===========================================================' + write (*, "(' Lx : ',F17.8)") xlx + write (*, "(' Ly : ',F17.8)") yly + write (*, "(' Lz : ',F17.8)") zlz + write (*, "(' nx : ',I17)") nx + write (*, "(' ny : ',I17)") ny + write (*, "(' nz : ',I17)") nz + write (*, *) '===========================================================' + write (*, "(' nu0nu : ',F17.8)") nu0nu + write (*, "(' cnu : ',F17.8)") cnu + write (*, *) '===========================================================' + write (*, "(' High and low speed : u1=',F6.2,' and u2=',F6.2)") u1, u2 + write (*, *) '===========================================================' + ! Show the compile flags detected and the version of the MPI library #ifdef DOUBLE_PREC #ifdef SAVE_SINGLE - write(*,*)'Numerical precision: Double, saving in single' + write (*, *) 'Numerical precision: Double, saving in single' #else - write(*,*)'Numerical precision: Double' + write (*, *) 'Numerical precision: Double' #endif #else - write(*,*)'Numerical precision: Single' + write (*, *) 'Numerical precision: Single' #endif - write(*,*)'Compiled with ', compiler_version() - write(*,*)'Compiler options : ', compiler_options() - write(*,'(" Version of the MPI library : ",I0,".",I0)') MPI_VERSION, MPI_SUBVERSION + write (*, *) 'Compiled with ', compiler_version() + write (*, *) 'Compiler options : ', compiler_options() + write (*, '(" Version of the MPI library : ",I0,".",I0)') MPI_VERSION, MPI_SUBVERSION #ifdef DEBUG - write(*,*)'Compile flag DEBUG detected' + write (*, *) 'Compile flag DEBUG detected' #endif #ifdef SHM - write(*,*)'Compile flag SHM detected' + write (*, *) 'Compile flag SHM detected' #endif #ifdef EVEN - write(*,*)'Compile flag EVEN detected' + write (*, *) 'Compile flag EVEN detected' #endif #ifdef OCC - write(*,*)'Compile flag OCC detected' + write (*, *) 'Compile flag OCC detected' #endif #ifdef OVERWRITE - write(*,*)'Compile flag OVERWRITE detected' + write (*, *) 'Compile flag OVERWRITE detected' #endif #ifdef HALO_DEBUG - write(*,*)'Compile flag HALO_DEBUG detected' + write (*, *) 'Compile flag HALO_DEBUG detected' #endif #ifdef SHM_DEBUG - write(*,*)'Compile flag SHM_DEBUG detected' + write (*, *) 'Compile flag SHM_DEBUG detected' #endif - write(*,*)'===========================================================' + write (*, *) '===========================================================' - endif + end if -end subroutine listing + end subroutine listing end module parameters diff --git a/src/poisson.f90 b/src/poisson.f90 index 4bc2122..30604b3 100644 --- a/src/poisson.f90 +++ b/src/poisson.f90 @@ -4,986 +4,985 @@ module decomp_2d_poisson - use decomp_2d, only : mytype - use decomp_2d, only : DECOMP_INFO - use decomp_2d, only : decomp_info_init, & + use decomp_2d, only: mytype + use decomp_2d, only: DECOMP_INFO + use decomp_2d, only: decomp_info_init, & decomp_info_finalize - use decomp_2d_fft, only : decomp_2d_fft_init, & - decomp_2d_fft_3d, & + use decomp_2d_fft, only: decomp_2d_fft_init, & + decomp_2d_fft_3d, & decomp_2d_fft_finalize - use x3d_transpose - use param - use variables + use x3d_transpose + use param + use variables - implicit none + implicit none - private ! Make everything private unless declared public + private ! Make everything private unless declared public - ! real(mytype), private, parameter :: PI = 3.14159265358979323846_mytype + ! real(mytype), private, parameter :: PI = 3.14159265358979323846_mytype #ifdef DOUBLE_PREC - real(mytype), parameter :: epsilon = 1.e-16_mytype + real(mytype), parameter :: epsilon = 1.e-16_mytype #else - real(mytype), parameter :: epsilon = 1.e-8_mytype + real(mytype), parameter :: epsilon = 1.e-8_mytype #endif - ! boundary conditions - integer, save :: bcx, bcy, bcz - - ! decomposition object for physical space - type(DECOMP_INFO), save :: ph - - ! decomposition object for spectral space - type(DECOMP_INFO), save :: sp - - ! store sine/cosine factors - real(mytype), save, allocatable, dimension(:) :: az,bz - real(mytype), save, allocatable, dimension(:) :: ay,by - real(mytype), save, allocatable, dimension(:) :: ax,bx - - ! wave numbers - complex(mytype), save, allocatable, dimension(:,:,:) :: kxyz - !wave numbers for stretching in a pentadiagonal matrice - complex(mytype), save, allocatable, dimension(:,:,:,:) :: a,a2,a3 - ! work arrays, - ! naming convention: cw (complex); rw (real); - ! 1 = X-pencil; 2 = Y-pencil; 3 = Z-pencil - real(mytype), allocatable, dimension(:,:,:) :: rw1,rw1b,rw2,rw2b,rw3 - complex(mytype), allocatable, dimension(:,:,:) :: cw1,cw1b,cw2,cw22,cw2b,cw2c - - ! underlying FFT library only needs to be initialised once - logical, save :: fft_initialised = .false. - - abstract interface - subroutine poisson_xxx(rhs) - use decomp_2d, only : mytype - real(mytype), dimension(:,:,:), intent(inout) :: rhs - end subroutine poisson_xxx - end interface - procedure (poisson_xxx), pointer :: poisson=>null() - - public :: decomp_2d_poisson_init,decomp_2d_poisson_finalize,poisson + ! boundary conditions + integer, save :: bcx, bcy, bcz + + ! decomposition object for physical space + type(DECOMP_INFO), save :: ph + + ! decomposition object for spectral space + type(DECOMP_INFO), save :: sp + + ! store sine/cosine factors + real(mytype), save, allocatable, dimension(:) :: az, bz + real(mytype), save, allocatable, dimension(:) :: ay, by + real(mytype), save, allocatable, dimension(:) :: ax, bx + + ! wave numbers + complex(mytype), save, allocatable, dimension(:, :, :) :: kxyz + !wave numbers for stretching in a pentadiagonal matrice + complex(mytype), save, allocatable, dimension(:, :, :, :) :: a, a2, a3 + ! work arrays, + ! naming convention: cw (complex); rw (real); + ! 1 = X-pencil; 2 = Y-pencil; 3 = Z-pencil + real(mytype), allocatable, dimension(:, :, :) :: rw1, rw1b, rw2, rw2b, rw3 + complex(mytype), allocatable, dimension(:, :, :) :: cw1, cw1b, cw2, cw22, cw2b, cw2c + + ! underlying FFT library only needs to be initialised once + logical, save :: fft_initialised = .false. + + abstract interface + subroutine poisson_xxx(rhs) + use decomp_2d, only: mytype + real(mytype), dimension(:, :, :), intent(inout) :: rhs + end subroutine poisson_xxx + end interface + procedure(poisson_xxx), pointer :: poisson => null() + + public :: decomp_2d_poisson_init, decomp_2d_poisson_finalize, poisson contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Initialise Poisson solver for given boundary conditions + ! Initialise Poisson solver for given boundary conditions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine decomp_2d_poisson_init() + subroutine decomp_2d_poisson_init() - use decomp_2d, only : nrank, nx_global, ny_global, nz_global + use decomp_2d, only: nrank, nx_global, ny_global, nz_global - implicit none + implicit none - integer :: nx, ny, nz, i + integer :: nx, ny, nz, i - real(mytype) :: rl, iy - external rl, iy + real(mytype) :: rl, iy + external rl, iy - if (nclx) then - bcx=0 - else - bcx=1 - endif - if (ncly) then - bcy=0 - else - bcy=1 - endif - if (nclz) then - bcz=0 - else - bcz=1 - endif + if (nclx) then + bcx = 0 + else + bcx = 1 + end if + if (ncly) then + bcy = 0 + else + bcy = 1 + end if + if (nclz) then + bcz = 0 + else + bcz = 1 + end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Top level wrapper + ! Top level wrapper !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (bcx==0 .and. bcy==0 .and. bcz==0) then - poisson => poisson_000 - else if (bcx==1 .and. bcy==0 .and. bcz==0) then - poisson => poisson_100 - else - stop 'boundary condition not supported' - end if - - nx = nx_global - ny = ny_global - nz = nz_global - - ! pressure-grid having 1 fewer point for non-periodic directions - if (bcx==1) nx=nx-1 - if (bcy==1) ny=ny-1 - if (bcz==1) nz=nz-1 + if (bcx == 0 .and. bcy == 0 .and. bcz == 0) then + poisson => poisson_000 + else if (bcx == 1 .and. bcy == 0 .and. bcz == 0) then + poisson => poisson_100 + else + stop 'boundary condition not supported' + end if + + nx = nx_global + ny = ny_global + nz = nz_global + + ! pressure-grid having 1 fewer point for non-periodic directions + if (bcx == 1) nx = nx - 1 + if (bcy == 1) ny = ny - 1 + if (bcz == 1) nz = nz - 1 #ifdef DEBUG - if (nrank .eq. 0) write(*,*)'# decomp_2d_poisson_init start' + if (nrank == 0) write (*, *) '# decomp_2d_poisson_init start' #endif - allocate(ax(nx),bx(nx)) - ax = zero - bx = zero - allocate(ay(ny),by(ny)) - ay = zero - by = zero - allocate(az(nz),bz(nz)) - az = zero - bz = zero - call abxyz(ax,ay,az,bx,by,bz,nx,ny,nz,bcx,bcy,bcz) + allocate (ax(nx), bx(nx)) + ax = zero + bx = zero + allocate (ay(ny), by(ny)) + ay = zero + by = zero + allocate (az(nz), bz(nz)) + az = zero + bz = zero + call abxyz(ax, ay, az, bx, by, bz, nx, ny, nz, bcx, bcy, bcz) #ifdef DEBUG - if (nrank .eq. 0) write(*,*)'# decomp_2d_poisson_init decomp_info_init' + if (nrank == 0) write (*, *) '# decomp_2d_poisson_init decomp_info_init' #endif - call decomp_info_init(nx, ny, nz, ph) - call decomp_info_init(nx, ny, nz/2+1, sp) + call decomp_info_init(nx, ny, nz, ph) + call decomp_info_init(nx, ny, nz/2 + 1, sp) #ifdef DEBUG - if (nrank .eq. 0) write(*,*)'# decomp_2d_poisson_init decomp_info_init ok' + if (nrank == 0) write (*, *) '# decomp_2d_poisson_init decomp_info_init ok' #endif - ! allocate work space - if (bcx==0 .and. bcy==0 .and. bcz==0) then - allocate(cw1(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), & - sp%xst(3):sp%xen(3))) - cw1 = zero - allocate(kxyz, source=cw1) - allocate(a(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5)) - a = zero - allocate(a2, source=a) - allocate(a3(sp%yst(1):sp%yen(1),ny,sp%yst(3):sp%yen(3),5)) - a3 = zero - else if (bcx==1 .and. bcy==0 .and. bcz==0) then - allocate(cw1(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), & - sp%xst(3):sp%xen(3))) - cw1 = zero - allocate(cw1b, source=cw1) - allocate(rw1(ph%xst(1):ph%xen(1),ph%xst(2):ph%xen(2), & - ph%xst(3):ph%xen(3))) - rw1 = zero - allocate(rw1b, source=rw1) - allocate(rw2(ph%yst(1):ph%yen(1),ph%yst(2):ph%yen(2), & - ph%yst(3):ph%yen(3))) - rw2 = zero - allocate(kxyz, source=cw1) - allocate(a(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5)) - a = zero - allocate(a2, source=a) - allocate(a3(sp%yst(1):sp%yen(1),ny,sp%yst(3):sp%yen(3),5)) - a3 = zero - else if (bcx==0 .and. bcy==1 .and. bcz==0) then - allocate(rw2(ph%yst(1):ph%yen(1),ph%yst(2):ph%yen(2), & - ph%yst(3):ph%yen(3))) - rw2 = zero - allocate(rw2b, source=rw2) - allocate(cw1(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), & - sp%xst(3):sp%xen(3))) - cw1 = zero - allocate(cw2(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), & - sp%yst(3):sp%yen(3))) - cw2 = zero - allocate(cw22, cw2b, cw2c, kxyz, source=cw2) - allocate(a(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5)) - a = zero - allocate(a2, source=a) - allocate(a3(sp%yst(1):sp%yen(1),ny,sp%yst(3):sp%yen(3),5)) - a3 = zero - else if (bcx==1 .and. bcy==1) then - allocate(cw1(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), & - sp%xst(3):sp%xen(3))) - cw1 = zero - allocate(cw1b, source=cw1) - allocate(cw2(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), & - sp%yst(3):sp%yen(3))) - cw2 = zero - allocate(cw22, cw2b, cw2c, source=cw2) - allocate(rw1(ph%xst(1):ph%xen(1),ph%xst(2):ph%xen(2), & - ph%xst(3):ph%xen(3))) - rw1 = zero - allocate(rw1b, source=rw1) - allocate(rw2(ph%yst(1):ph%yen(1),ph%yst(2):ph%yen(2), & - ph%yst(3):ph%yen(3))) - rw2 = zero - allocate(rw2b, source=rw2) - if (bcz==1) then - allocate(rw3(ph%zsz(1),ph%zsz(2),ph%zsz(3))) - rw3 = zero - end if - allocate(kxyz, source=cw1) - allocate(a(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5)) - a = zero - allocate(a2, source=a) - allocate(a3(sp%yst(1):sp%yen(1),nym,sp%yst(3):sp%yen(3),5)) - a3 = zero - end if + ! allocate work space + if (bcx == 0 .and. bcy == 0 .and. bcz == 0) then + allocate (cw1(sp%xst(1):sp%xen(1), sp%xst(2):sp%xen(2), & + sp%xst(3):sp%xen(3))) + cw1 = zero + allocate (kxyz, source=cw1) + allocate (a(sp%yst(1):sp%yen(1), ny/2, sp%yst(3):sp%yen(3), 5)) + a = zero + allocate (a2, source=a) + allocate (a3(sp%yst(1):sp%yen(1), ny, sp%yst(3):sp%yen(3), 5)) + a3 = zero + else if (bcx == 1 .and. bcy == 0 .and. bcz == 0) then + allocate (cw1(sp%xst(1):sp%xen(1), sp%xst(2):sp%xen(2), & + sp%xst(3):sp%xen(3))) + cw1 = zero + allocate (cw1b, source=cw1) + allocate (rw1(ph%xst(1):ph%xen(1), ph%xst(2):ph%xen(2), & + ph%xst(3):ph%xen(3))) + rw1 = zero + allocate (rw1b, source=rw1) + allocate (rw2(ph%yst(1):ph%yen(1), ph%yst(2):ph%yen(2), & + ph%yst(3):ph%yen(3))) + rw2 = zero + allocate (kxyz, source=cw1) + allocate (a(sp%yst(1):sp%yen(1), ny/2, sp%yst(3):sp%yen(3), 5)) + a = zero + allocate (a2, source=a) + allocate (a3(sp%yst(1):sp%yen(1), ny, sp%yst(3):sp%yen(3), 5)) + a3 = zero + else if (bcx == 0 .and. bcy == 1 .and. bcz == 0) then + allocate (rw2(ph%yst(1):ph%yen(1), ph%yst(2):ph%yen(2), & + ph%yst(3):ph%yen(3))) + rw2 = zero + allocate (rw2b, source=rw2) + allocate (cw1(sp%xst(1):sp%xen(1), sp%xst(2):sp%xen(2), & + sp%xst(3):sp%xen(3))) + cw1 = zero + allocate (cw2(sp%yst(1):sp%yen(1), sp%yst(2):sp%yen(2), & + sp%yst(3):sp%yen(3))) + cw2 = zero + allocate (cw22, cw2b, cw2c, kxyz, source=cw2) + allocate (a(sp%yst(1):sp%yen(1), ny/2, sp%yst(3):sp%yen(3), 5)) + a = zero + allocate (a2, source=a) + allocate (a3(sp%yst(1):sp%yen(1), ny, sp%yst(3):sp%yen(3), 5)) + a3 = zero + else if (bcx == 1 .and. bcy == 1) then + allocate (cw1(sp%xst(1):sp%xen(1), sp%xst(2):sp%xen(2), & + sp%xst(3):sp%xen(3))) + cw1 = zero + allocate (cw1b, source=cw1) + allocate (cw2(sp%yst(1):sp%yen(1), sp%yst(2):sp%yen(2), & + sp%yst(3):sp%yen(3))) + cw2 = zero + allocate (cw22, cw2b, cw2c, source=cw2) + allocate (rw1(ph%xst(1):ph%xen(1), ph%xst(2):ph%xen(2), & + ph%xst(3):ph%xen(3))) + rw1 = zero + allocate (rw1b, source=rw1) + allocate (rw2(ph%yst(1):ph%yen(1), ph%yst(2):ph%yen(2), & + ph%yst(3):ph%yen(3))) + rw2 = zero + allocate (rw2b, source=rw2) + if (bcz == 1) then + allocate (rw3(ph%zsz(1), ph%zsz(2), ph%zsz(3))) + rw3 = zero + end if + allocate (kxyz, source=cw1) + allocate (a(sp%yst(1):sp%yen(1), ny/2, sp%yst(3):sp%yen(3), 5)) + a = zero + allocate (a2, source=a) + allocate (a3(sp%yst(1):sp%yen(1), nym, sp%yst(3):sp%yen(3), 5)) + a3 = zero + end if #ifdef DEBUG - if (nrank .eq. 0) write(*,*)'# decomp_2d_poisson_init before waves' + if (nrank == 0) write (*, *) '# decomp_2d_poisson_init before waves' #endif - call waves() + call waves() #ifdef DEBUG - if (nrank .eq. 0) write(*,*)'# decomp_2d_poisson_init end' + if (nrank == 0) write (*, *) '# decomp_2d_poisson_init end' #endif - return - end subroutine decomp_2d_poisson_init - + return + end subroutine decomp_2d_poisson_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Release memory used by Poisson solver + ! Release memory used by Poisson solver !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine decomp_2d_poisson_finalize + subroutine decomp_2d_poisson_finalize - implicit none + implicit none - nullify(poisson) + nullify (poisson) - deallocate(ax,bx,ay,by,az,bz) + deallocate (ax, bx, ay, by, az, bz) - call decomp_info_finalize(ph) - call decomp_info_finalize(sp) + call decomp_info_finalize(ph) + call decomp_info_finalize(sp) - call decomp_2d_fft_finalize - fft_initialised = .false. + call decomp_2d_fft_finalize + fft_initialised = .false. - deallocate(kxyz) + deallocate (kxyz) - if (bcx==0 .and. bcy==0 .and. bcz==0) then - deallocate(cw1) - deallocate(a,a2,a3) - else if (bcx==1 .and. bcy==0 .and. bcz==0) then - deallocate(cw1,cw1b,rw1,rw1b,rw2) - deallocate(a,a2,a3) - else if (bcx==0 .and. bcy==1 .and. bcz==0) then - deallocate(cw1,cw2,cw2b,rw2,rw2b) - deallocate(a,a2,a3) - else if (bcx==1 .and. bcy==1) then - deallocate(cw1,cw1b,cw2,cw2b,rw1,rw1b,rw2,rw2b) - deallocate(a,a2,a3) - if (bcz==1) then - deallocate(rw3) - end if - end if + if (bcx == 0 .and. bcy == 0 .and. bcz == 0) then + deallocate (cw1) + deallocate (a, a2, a3) + else if (bcx == 1 .and. bcy == 0 .and. bcz == 0) then + deallocate (cw1, cw1b, rw1, rw1b, rw2) + deallocate (a, a2, a3) + else if (bcx == 0 .and. bcy == 1 .and. bcz == 0) then + deallocate (cw1, cw2, cw2b, rw2, rw2b) + deallocate (a, a2, a3) + else if (bcx == 1 .and. bcy == 1) then + deallocate (cw1, cw1b, cw2, cw2b, rw1, rw1b, rw2, rw2b) + deallocate (a, a2, a3) + if (bcz == 1) then + deallocate (rw3) + end if + end if - return - end subroutine decomp_2d_poisson_finalize + return + end subroutine decomp_2d_poisson_finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Solving 3D Poisson equation with periodic B.C in all 3 dimensions + ! Solving 3D Poisson equation with periodic B.C in all 3 dimensions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine poisson_000(rhs) - - use x3d_operator_x_data - use x3d_operator_y_data - use x3d_operator_z_data - use decomp_2d, only : nx_global, ny_global, nz_global - use decomp_2d_fft, only : PHYSICAL_IN_Z - - ! right-hand-side of Poisson as input - ! solution of Poisson as output - real(mytype), dimension(:,:,:), intent(INOUT) :: rhs - - integer, dimension(3) :: fft_start, fft_end, fft_size - - complex(mytype) :: xyzk - - complex(mytype) :: ytt,xtt,ztt,yt1,xt1,yt2,xt2 - complex(mytype) :: xtt1,ytt1,ztt1,zt1,zt2 - - - real(mytype) :: tmp1, tmp2,x ,y, z - - integer :: nx,ny,nz, i,j,k - - complex(mytype) :: cx - real(mytype) :: rl, iy - external cx, rl, iy - - nx = nx_global - ny = ny_global - nz = nz_global - - if (.not. fft_initialised) then - call decomp_2d_fft_init(PHYSICAL_IN_Z) - fft_initialised = .true. - end if - - ! compute r2c transform - call decomp_2d_fft_3d(rhs,cw1) - - ! normalisation - cw1 = cw1 / real(nx, kind=mytype) /real(ny, kind=mytype) & - / real(nz, kind=mytype) - - do concurrent(k=sp%xst(3):sp%xen(3), j=sp%xst(2):sp%xen(2),i=sp%xst(1):sp%xen(1)) - ! POST PROCESSING IN Z - tmp1 = real(cw1(i,j,k), kind=mytype) - tmp2 = aimag(cw1(i,j,k)) - cw1(i,j,k) = cmplx(tmp1 * bz(k) + tmp2 * az(k), & - tmp2 * bz(k) - tmp1 * az(k), kind=mytype) - - ! POST PROCESSING IN Y - tmp1 = real(cw1(i,j,k), kind=mytype) - tmp2 = aimag(cw1(i,j,k)) - cw1(i,j,k) = cmplx(tmp1 * by(j) + tmp2 * ay(j), & - tmp2 * by(j) - tmp1 * ay(j), kind=mytype) - if (j > (ny/2+1)) cw1(i,j,k) = -cw1(i,j,k) - - ! POST PROCESSING IN X - tmp1 = real(cw1(i,j,k), kind=mytype) - tmp2 = aimag(cw1(i,j,k)) - cw1(i,j,k) = cmplx(tmp1 * bx(i) + tmp2 * ax(i), & - tmp2 * bx(i) - tmp1 * ax(i), kind=mytype) - if (i > (nx/2+1)) cw1(i,j,k) = -cw1(i,j,k) - - ! Solve Poisson - tmp1 = real(kxyz(i,j,k), kind=mytype) - tmp2 = aimag(kxyz(i,j,k)) - ! CANNOT DO A DIVISION BY ZERO - if ((tmp1 < epsilon).or.(tmp2 < epsilon)) then - cw1(i,j,k) = zero - else - cw1(i,j,k) = cmplx(real(cw1(i,j,k),kind=mytype) / (-tmp1), & - aimag(cw1(i,j,k)) / (-tmp2), kind=mytype) - end if - - !Print result in spectal space after Poisson - ! if (abs(out(i,j,k)) > 1.0e-4) then - ! write(*,*) 'AFTER',i,j,k,out(i,j,k),xyzk - ! end if - - ! post-processing backward - - ! POST PROCESSING IN Z - tmp1 = real(cw1(i,j,k), kind=mytype) - tmp2 = aimag(cw1(i,j,k)) - cw1(i,j,k) = cmplx(tmp1 * bz(k) - tmp2 * az(k), & - -tmp2 * bz(k) - tmp1 * az(k), kind=mytype) - - ! POST PROCESSING IN Y - tmp1 = real(cw1(i,j,k), kind=mytype) - tmp2 = aimag(cw1(i,j,k)) - cw1(i,j,k) = cmplx(tmp1 * by(j) + tmp2 * ay(j), & - tmp2 * by(j) - tmp1 * ay(j), kind=mytype) - if (j > (ny/2 + 1)) cw1(i,j,k) = -cw1(i,j,k) - - ! POST PROCESSING IN X - tmp1 = real(cw1(i,j,k), kind=mytype) - tmp2 = aimag(cw1(i,j,k)) - cw1(i,j,k) = cmplx(tmp1 * bx(i) + tmp2 * ax(i), & - -tmp2 * bx(i) + tmp1 * ax(i), kind=mytype) - if (i > (nx/2+1)) cw1(i,j,k) = -cw1(i,j,k) - ! post-processing in spectral space - - - end do + subroutine poisson_000(rhs) + + use x3d_operator_x_data + use x3d_operator_y_data + use x3d_operator_z_data + use decomp_2d, only: nx_global, ny_global, nz_global + use decomp_2d_fft, only: PHYSICAL_IN_Z + + ! right-hand-side of Poisson as input + ! solution of Poisson as output + real(mytype), dimension(:, :, :), intent(INOUT) :: rhs + + integer, dimension(3) :: fft_start, fft_end, fft_size + + complex(mytype) :: xyzk + + complex(mytype) :: ytt, xtt, ztt, yt1, xt1, yt2, xt2 + complex(mytype) :: xtt1, ytt1, ztt1, zt1, zt2 + + real(mytype) :: tmp1, tmp2, x, y, z + + integer :: nx, ny, nz, i, j, k - ! compute c2r transform - call decomp_2d_fft_3d(cw1,rhs) + complex(mytype) :: cx + real(mytype) :: rl, iy + external cx, rl, iy - ! call decomp_2d_fft_finalize + nx = nx_global + ny = ny_global + nz = nz_global - return - end subroutine poisson_000 + if (.not. fft_initialised) then + call decomp_2d_fft_init(PHYSICAL_IN_Z) + fft_initialised = .true. + end if + ! compute r2c transform + call decomp_2d_fft_3d(rhs, cw1) - subroutine poisson_100(rhs) - - use decomp_2d, only : nx_global, ny_global, nz_global - use decomp_2d_fft, only : PHYSICAL_IN_Z - - implicit none - - real(mytype), dimension(:,:,:), intent(INOUT) :: rhs - - complex(mytype) :: xyzk - real(mytype) :: tmp1, tmp2, tmp3, tmp4 - real(mytype) :: xx1,xx2,xx3,xx4,xx5,xx6,xx7,xx8 - - integer :: nx,ny,nz, i,j,k, itmp - - complex(mytype) :: cx - real(mytype) :: rl, iy - external cx, rl, iy - -100 format(1x,a8,3I4,2F12.6) - - nx = nx_global - 1 - ny = ny_global - nz = nz_global - - ! rhs is in Z-pencil but requires global operations in X - call x3d_transpose_z_to_y(rhs,rw2,ph) - call x3d_transpose_y_to_x(rw2,rw1,ph) - do k=ph%xst(3),ph%xen(3) - do j=ph%xst(2),ph%xen(2) - do i=1,nx/2 - rw1b(i,j,k)=rw1(2*(i-1)+1,j,k) - enddo - do i=nx/2+1,nx - rw1b(i,j,k)=rw1(2*nx-2*i+2,j,k) - enddo - enddo - end do - - call x3d_transpose_x_to_y(rw1b,rw2,ph) - call x3d_transpose_y_to_z(rw2,rhs,ph) - - if (.not. fft_initialised) then - call decomp_2d_fft_init(PHYSICAL_IN_Z,nx,ny,nz) - fft_initialised = .true. - end if + ! normalisation + cw1 = cw1/real(nx, kind=mytype)/real(ny, kind=mytype) & + /real(nz, kind=mytype) - ! compute r2c transform - call decomp_2d_fft_3d(rhs,cw1) - - ! normalisation - cw1 = cw1 / real(nx, kind=mytype) /real(ny, kind=mytype) & - / real(nz, kind=mytype) + do concurrent(k=sp%xst(3):sp%xen(3), j=sp%xst(2):sp%xen(2), i=sp%xst(1):sp%xen(1)) + ! POST PROCESSING IN Z + tmp1 = real(cw1(i, j, k), kind=mytype) + tmp2 = aimag(cw1(i, j, k)) + cw1(i, j, k) = cmplx(tmp1*bz(k) + tmp2*az(k), & + tmp2*bz(k) - tmp1*az(k), kind=mytype) + + ! POST PROCESSING IN Y + tmp1 = real(cw1(i, j, k), kind=mytype) + tmp2 = aimag(cw1(i, j, k)) + cw1(i, j, k) = cmplx(tmp1*by(j) + tmp2*ay(j), & + tmp2*by(j) - tmp1*ay(j), kind=mytype) + if (j > (ny/2 + 1)) cw1(i, j, k) = -cw1(i, j, k) + + ! POST PROCESSING IN X + tmp1 = real(cw1(i, j, k), kind=mytype) + tmp2 = aimag(cw1(i, j, k)) + cw1(i, j, k) = cmplx(tmp1*bx(i) + tmp2*ax(i), & + tmp2*bx(i) - tmp1*ax(i), kind=mytype) + if (i > (nx/2 + 1)) cw1(i, j, k) = -cw1(i, j, k) + + ! Solve Poisson + tmp1 = real(kxyz(i, j, k), kind=mytype) + tmp2 = aimag(kxyz(i, j, k)) + ! CANNOT DO A DIVISION BY ZERO + if ((tmp1 < epsilon) .or. (tmp2 < epsilon)) then + cw1(i, j, k) = zero + else + cw1(i, j, k) = cmplx(real(cw1(i, j, k), kind=mytype)/(-tmp1), & + aimag(cw1(i, j, k))/(-tmp2), kind=mytype) + end if + + !Print result in spectal space after Poisson + ! if (abs(out(i,j,k)) > 1.0e-4) then + ! write(*,*) 'AFTER',i,j,k,out(i,j,k),xyzk + ! end if + + ! post-processing backward + + ! POST PROCESSING IN Z + tmp1 = real(cw1(i, j, k), kind=mytype) + tmp2 = aimag(cw1(i, j, k)) + cw1(i, j, k) = cmplx(tmp1*bz(k) - tmp2*az(k), & + -tmp2*bz(k) - tmp1*az(k), kind=mytype) + + ! POST PROCESSING IN Y + tmp1 = real(cw1(i, j, k), kind=mytype) + tmp2 = aimag(cw1(i, j, k)) + cw1(i, j, k) = cmplx(tmp1*by(j) + tmp2*ay(j), & + tmp2*by(j) - tmp1*ay(j), kind=mytype) + if (j > (ny/2 + 1)) cw1(i, j, k) = -cw1(i, j, k) + + ! POST PROCESSING IN X + tmp1 = real(cw1(i, j, k), kind=mytype) + tmp2 = aimag(cw1(i, j, k)) + cw1(i, j, k) = cmplx(tmp1*bx(i) + tmp2*ax(i), & + -tmp2*bx(i) + tmp1*ax(i), kind=mytype) + if (i > (nx/2 + 1)) cw1(i, j, k) = -cw1(i, j, k) + ! post-processing in spectral space + + end do + + ! compute c2r transform + call decomp_2d_fft_3d(cw1, rhs) + + ! call decomp_2d_fft_finalize + + return + end subroutine poisson_000 + + subroutine poisson_100(rhs) + + use decomp_2d, only: nx_global, ny_global, nz_global + use decomp_2d_fft, only: PHYSICAL_IN_Z + + implicit none + + real(mytype), dimension(:, :, :), intent(INOUT) :: rhs + + complex(mytype) :: xyzk + real(mytype) :: tmp1, tmp2, tmp3, tmp4 + real(mytype) :: xx1, xx2, xx3, xx4, xx5, xx6, xx7, xx8 + + integer :: nx, ny, nz, i, j, k, itmp + + complex(mytype) :: cx + real(mytype) :: rl, iy + external cx, rl, iy + +100 format(1x, a8, 3I4, 2F12.6) + + nx = nx_global - 1 + ny = ny_global + nz = nz_global + + ! rhs is in Z-pencil but requires global operations in X + call x3d_transpose_z_to_y(rhs, rw2, ph) + call x3d_transpose_y_to_x(rw2, rw1, ph) + do k = ph%xst(3), ph%xen(3) + do j = ph%xst(2), ph%xen(2) + do i = 1, nx/2 + rw1b(i, j, k) = rw1(2*(i - 1) + 1, j, k) + end do + do i = nx/2 + 1, nx + rw1b(i, j, k) = rw1(2*nx - 2*i + 2, j, k) + end do + end do + end do + + call x3d_transpose_x_to_y(rw1b, rw2, ph) + call x3d_transpose_y_to_z(rw2, rhs, ph) + + if (.not. fft_initialised) then + call decomp_2d_fft_init(PHYSICAL_IN_Z, nx, ny, nz) + fft_initialised = .true. + end if + + ! compute r2c transform + call decomp_2d_fft_3d(rhs, cw1) + + ! normalisation + cw1 = cw1/real(nx, kind=mytype)/real(ny, kind=mytype) & + /real(nz, kind=mytype) #ifdef DEBUG - do k = sp%xst(3),sp%xen(3) - do j = sp%xst(2),sp%xen(2) - do i = sp%xst(1),sp%xen(1) - if (abs(cw1(i,j,k)) > 1.0e-4) then - write(*,100) 'START',i,j,k,cw1(i,j,k) - end if - end do - end do - end do + do k = sp%xst(3), sp%xen(3) + do j = sp%xst(2), sp%xen(2) + do i = sp%xst(1), sp%xen(1) + if (abs(cw1(i, j, k)) > 1.0e-4) then + write (*, 100) 'START', i, j, k, cw1(i, j, k) + end if + end do + end do + end do #endif - ! post-processing in spectral space + ! post-processing in spectral space - ! POST PROCESSING IN Z - do k = sp%xst(3), sp%xen(3) - do j = sp%xst(2), sp%xen(2) - do i = sp%xst(1), sp%xen(1) - tmp1 = rl(cw1(i,j,k)) - tmp2 = iy(cw1(i,j,k)) - cw1(i,j,k) = cx(tmp1 * bz(k) + tmp2 * az(k), & - tmp2 * bz(k) - tmp1 * az(k)) + ! POST PROCESSING IN Z + do k = sp%xst(3), sp%xen(3) + do j = sp%xst(2), sp%xen(2) + do i = sp%xst(1), sp%xen(1) + tmp1 = rl(cw1(i, j, k)) + tmp2 = iy(cw1(i, j, k)) + cw1(i, j, k) = cx(tmp1*bz(k) + tmp2*az(k), & + tmp2*bz(k) - tmp1*az(k)) #ifdef DEBUG - if (abs(cw1(i,j,k)) > 1.0e-4) & - write(*,100) 'after z',i,j,k,cw1(i,j,k) + if (abs(cw1(i, j, k)) > 1.0e-4) then + write (*, 100) 'after z', i, j, k, cw1(i, j, k) + end if #endif - end do - end do - end do - - ! POST PROCESSING IN Y - do k = sp%xst(3), sp%xen(3) - do j = sp%xst(2), sp%xen(2) - do i = sp%xst(1), sp%xen(1) - tmp1 = rl(cw1(i,j,k)) - tmp2 = iy(cw1(i,j,k)) - cw1(i,j,k) = cx(tmp1 * by(j) + tmp2 * ay(j), & - tmp2 * by(j) - tmp1 * ay(j)) - if (j > (ny/2+1)) cw1(i,j,k) = -cw1(i,j,k) + end do + end do + end do + + ! POST PROCESSING IN Y + do k = sp%xst(3), sp%xen(3) + do j = sp%xst(2), sp%xen(2) + do i = sp%xst(1), sp%xen(1) + tmp1 = rl(cw1(i, j, k)) + tmp2 = iy(cw1(i, j, k)) + cw1(i, j, k) = cx(tmp1*by(j) + tmp2*ay(j), & + tmp2*by(j) - tmp1*ay(j)) + if (j > (ny/2 + 1)) cw1(i, j, k) = -cw1(i, j, k) #ifdef DEBUG - if (abs(cw1(i,j,k)) > 1.0e-4) & - write(*,100) 'after y',i,j,k,cw1(i,j,k) + if (abs(cw1(i, j, k)) > 1.0e-4) then + write (*, 100) 'after y', i, j, k, cw1(i, j, k) + end if #endif - end do - end do - end do - - ! POST PROCESSING IN X - do k = sp%xst(3), sp%xen(3) - do j = sp%xst(2), sp%xen(2) - cw1b(1,j,k) = cw1(1,j,k) - do i = 2, nx - tmp1 = rl(cw1(i,j,k)) - tmp2 = iy(cw1(i,j,k)) - tmp3 = rl(cw1(nx-i+2,j,k)) - tmp4 = iy(cw1(nx-i+2,j,k)) - xx1=tmp1 * bx(i) - xx2=tmp1 * ax(i) - xx3=tmp2 * bx(i) - xx4=tmp2 * ax(i) - xx5=tmp3 * bx(i) - xx6=tmp3 * ax(i) - xx7=tmp4 * bx(i) - xx8=tmp4 * ax(i) - cw1b(i,j,k) = half * cx(xx1 + xx4 + xx5 - xx8, & - -xx2 + xx3 + xx6 + xx7) - end do - end do - end do + end do + end do + end do + + ! POST PROCESSING IN X + do k = sp%xst(3), sp%xen(3) + do j = sp%xst(2), sp%xen(2) + cw1b(1, j, k) = cw1(1, j, k) + do i = 2, nx + tmp1 = rl(cw1(i, j, k)) + tmp2 = iy(cw1(i, j, k)) + tmp3 = rl(cw1(nx - i + 2, j, k)) + tmp4 = iy(cw1(nx - i + 2, j, k)) + xx1 = tmp1*bx(i) + xx2 = tmp1*ax(i) + xx3 = tmp2*bx(i) + xx4 = tmp2*ax(i) + xx5 = tmp3*bx(i) + xx6 = tmp3*ax(i) + xx7 = tmp4*bx(i) + xx8 = tmp4*ax(i) + cw1b(i, j, k) = half*cx(xx1 + xx4 + xx5 - xx8, & + -xx2 + xx3 + xx6 + xx7) + end do + end do + end do #ifdef DEBUG - do k = sp%xst(3),sp%xen(3) - do j = sp%xst(2),sp%xen(2) - do i = sp%xst(1),sp%xen(1) - if (abs(cw1b(i,j,k)) > 1.0e-4) then - write(*,100) 'after x',i,j,k,cw1b(i,j,k) - end if - end do - end do - end do + do k = sp%xst(3), sp%xen(3) + do j = sp%xst(2), sp%xen(2) + do i = sp%xst(1), sp%xen(1) + if (abs(cw1b(i, j, k)) > 1.0e-4) then + write (*, 100) 'after x', i, j, k, cw1b(i, j, k) + end if + end do + end do + end do #endif - ! Solve Poisson - do k = sp%xst(3), sp%xen(3) - do j = sp%xst(2), sp%xen(2) - do i = sp%xst(1), sp%xen(1) - tmp1 = rl(kxyz(i,j,k)) - tmp2 = iy(kxyz(i,j,k)) - ! CANNOT DO A DIVISION BY ZERO - if ((abs(tmp1) < epsilon).and.(abs(tmp2) < epsilon)) then - cw1b(i,j,k)=cx(zero, zero) - end if - if ((abs(tmp1) < epsilon).and.(abs(tmp2) >= epsilon)) then - cw1b(i,j,k)=cx(zero, iy(cw1b(i,j,k)) / (-tmp2)) - end if - if ((abs(tmp1) >= epsilon).and.(abs(tmp2) < epsilon)) then - cw1b(i,j,k)=cx(rl(cw1b(i,j,k)) / (-tmp1), zero) - end if - if ((abs(tmp1) >= epsilon).and.(abs(tmp2) >= epsilon)) then - cw1b(i,j,k)=cx(rl(cw1b(i,j,k)) / (-tmp1), iy(cw1b(i,j,k)) / (-tmp2)) - end if + ! Solve Poisson + do k = sp%xst(3), sp%xen(3) + do j = sp%xst(2), sp%xen(2) + do i = sp%xst(1), sp%xen(1) + tmp1 = rl(kxyz(i, j, k)) + tmp2 = iy(kxyz(i, j, k)) + ! CANNOT DO A DIVISION BY ZERO + if ((abs(tmp1) < epsilon) .and. (abs(tmp2) < epsilon)) then + cw1b(i, j, k) = cx(zero, zero) + end if + if ((abs(tmp1) < epsilon) .and. (abs(tmp2) >= epsilon)) then + cw1b(i, j, k) = cx(zero, iy(cw1b(i, j, k))/(-tmp2)) + end if + if ((abs(tmp1) >= epsilon) .and. (abs(tmp2) < epsilon)) then + cw1b(i, j, k) = cx(rl(cw1b(i, j, k))/(-tmp1), zero) + end if + if ((abs(tmp1) >= epsilon) .and. (abs(tmp2) >= epsilon)) then + cw1b(i, j, k) = cx(rl(cw1b(i, j, k))/(-tmp1), iy(cw1b(i, j, k))/(-tmp2)) + end if #ifdef DEBUG - if (abs(cw1b(i,j,k)) > 1.0e-4) & - write(*,100) 'AFTER',i,j,k,cw1b(i,j,k) + if (abs(cw1b(i, j, k)) > 1.0e-4) then + write (*, 100) 'AFTER', i, j, k, cw1b(i, j, k) + end if #endif - end do - end do - end do - - ! post-processing backward - - ! POST PROCESSING IN X - do k = sp%xst(3), sp%xen(3) - do j = sp%xst(2), sp%xen(2) - cw1(1,j,k) = cw1b(1,j,k) - do i = 2, nx - tmp1 = rl(cw1b(i,j,k)) - tmp2 = iy(cw1b(i,j,k)) - tmp3 = rl(cw1b(nx-i+2,j,k)) - tmp4 = iy(cw1b(nx-i+2,j,k)) - xx1 = tmp1 * bx(i) - xx2 = tmp1 * ax(i) - xx3 = tmp2 * bx(i) - xx4 = tmp2 * ax(i) - xx5 = tmp3 * bx(i) - xx6 = tmp3 * ax(i) - xx7 = tmp4 * bx(i) - xx8 = tmp4 * ax(i) - cw1(i,j,k) = cx(xx1-xx4+xx6+xx7, & - -(-xx2-xx3+xx5-xx8)) - end do - end do - end do + end do + end do + end do + + ! post-processing backward + + ! POST PROCESSING IN X + do k = sp%xst(3), sp%xen(3) + do j = sp%xst(2), sp%xen(2) + cw1(1, j, k) = cw1b(1, j, k) + do i = 2, nx + tmp1 = rl(cw1b(i, j, k)) + tmp2 = iy(cw1b(i, j, k)) + tmp3 = rl(cw1b(nx - i + 2, j, k)) + tmp4 = iy(cw1b(nx - i + 2, j, k)) + xx1 = tmp1*bx(i) + xx2 = tmp1*ax(i) + xx3 = tmp2*bx(i) + xx4 = tmp2*ax(i) + xx5 = tmp3*bx(i) + xx6 = tmp3*ax(i) + xx7 = tmp4*bx(i) + xx8 = tmp4*ax(i) + cw1(i, j, k) = cx(xx1 - xx4 + xx6 + xx7, & + -(-xx2 - xx3 + xx5 - xx8)) + end do + end do + end do #ifdef DEBUG - do k = sp%xst(3),sp%xen(3) - do j = sp%xst(2),sp%xen(2) - do i = sp%xst(1),sp%xen(1) - if (abs(cw1(i,j,k)) > 1.0e-4) then - write(*,100) 'AFTER X',i,j,k,cw1(i,j,k) - end if - end do - end do - end do + do k = sp%xst(3), sp%xen(3) + do j = sp%xst(2), sp%xen(2) + do i = sp%xst(1), sp%xen(1) + if (abs(cw1(i, j, k)) > 1.0e-4) then + write (*, 100) 'AFTER X', i, j, k, cw1(i, j, k) + end if + end do + end do + end do #endif - ! POST PROCESSING IN Y - do k = sp%xst(3), sp%xen(3) - do j = sp%xst(2), sp%xen(2) - do i = sp%xst(1), sp%xen(1) - tmp1 = rl(cw1(i,j,k)) - tmp2 = iy(cw1(i,j,k)) - cw1(i,j,k) = cx(tmp1 * by(j) - tmp2 * ay(j), & - tmp2 * by(j) + tmp1 * ay(j)) - if (j > (ny/2+1)) cw1(i,j,k) = -cw1(i,j,k) + ! POST PROCESSING IN Y + do k = sp%xst(3), sp%xen(3) + do j = sp%xst(2), sp%xen(2) + do i = sp%xst(1), sp%xen(1) + tmp1 = rl(cw1(i, j, k)) + tmp2 = iy(cw1(i, j, k)) + cw1(i, j, k) = cx(tmp1*by(j) - tmp2*ay(j), & + tmp2*by(j) + tmp1*ay(j)) + if (j > (ny/2 + 1)) cw1(i, j, k) = -cw1(i, j, k) #ifdef DEBUG - if (abs(cw1(i,j,k)) > 1.0e-4) & - write(*,100) 'AFTER Y',i,j,k,cw1(i,j,k) + if (abs(cw1(i, j, k)) > 1.0e-4) then + write (*, 100) 'AFTER Y', i, j, k, cw1(i, j, k) + end if #endif - end do - end do - end do - - ! POST PROCESSING IN Z - do k = sp%xst(3), sp%xen(3) - do j = sp%xst(2), sp%xen(2) - do i = sp%xst(1), sp%xen(1) - tmp1 = rl(cw1(i,j,k)) - tmp2 = iy(cw1(i,j,k)) - cw1(i,j,k) = cx(tmp1 * bz(k) - tmp2 * az(k), & - tmp2 * bz(k) + tmp1 * az(k)) + end do + end do + end do + + ! POST PROCESSING IN Z + do k = sp%xst(3), sp%xen(3) + do j = sp%xst(2), sp%xen(2) + do i = sp%xst(1), sp%xen(1) + tmp1 = rl(cw1(i, j, k)) + tmp2 = iy(cw1(i, j, k)) + cw1(i, j, k) = cx(tmp1*bz(k) - tmp2*az(k), & + tmp2*bz(k) + tmp1*az(k)) #ifdef DEBUG - if (abs(cw1(i,j,k)) > 1.0e-4) & - write(*,100) 'END',i,j,k,cw1(i,j,k) + if (abs(cw1(i, j, k)) > 1.0e-4) then + write (*, 100) 'END', i, j, k, cw1(i, j, k) + end if #endif - end do - end do - end do - - ! compute c2r transform - call decomp_2d_fft_3d(cw1,rhs) - - ! rhs is in Z-pencil but requires global operations in X - call x3d_transpose_z_to_y(rhs,rw2,ph) - call x3d_transpose_y_to_x(rw2,rw1,ph) - do k = ph%xst(3), ph%xen(3) - do j = ph%xst(2), ph%xen(2) - do i = 1, nx/2 - rw1b(2*i-1,j,k) = rw1(i,j,k) - enddo - do i = 1, nx/2 - rw1b(2*i,j,k) = rw1(nx-i+1,j,k) - enddo - enddo - end do - call x3d_transpose_x_to_y(rw1b,rw2,ph) - call x3d_transpose_y_to_z(rw2,rhs,ph) - - ! call decomp_2d_fft_finalize - - return - end subroutine poisson_100 - - subroutine abxyz(ax,ay,az,bx,by,bz,nx,ny,nz,bcx,bcy,bcz) - - use param - use x3d_precision, only : pi - - implicit none - - integer, intent(IN) :: nx,ny,nz - integer, intent(IN) :: bcx,bcy,bcz - real(mytype), dimension(:), intent(OUT) :: ax,bx - real(mytype), dimension(:), intent(OUT) :: ay,by - real(mytype), dimension(:), intent(OUT) :: az,bz - - integer :: i,j,k - - if (bcx==0) then - do i=1,nx - ax(i) = sin(real(i-1, kind=mytype)*pi/real(nx, kind=mytype)) - bx(i) = cos(real(i-1, kind=mytype)*pi/real(nx, kind=mytype)) - end do - else if (bcx==1) then - do i=1,nx - ax(i) = sin(real(i-1, kind=mytype)*pi/two/ & - real(nx, kind=mytype)) - bx(i) = cos(real(i-1, kind=mytype)*pi/two/ & - real(nx, kind=mytype)) - end do - end if - - if (bcy==0) then - do j=1,ny - ay(j) = sin(real(j-1, kind=mytype)*pi/real(ny, kind=mytype)) - by(j) = cos(real(j-1, kind=mytype)*pi/real(ny, kind=mytype)) - end do - else if (bcy==1) then - do j=1,ny - ay(j) = sin(real(j-1, kind=mytype)*pi/two/ & - real(ny, kind=mytype)) - by(j) = cos(real(j-1, kind=mytype)*pi/two/ & - real(ny, kind=mytype)) - end do - end if - - if (bcz==0) then - do k=1,nz - az(k) = sin(real(k-1, kind=mytype)*pi/real(nz, kind=mytype)) - bz(k) = cos(real(k-1, kind=mytype)*pi/real(nz, kind=mytype)) - end do - else if (bcz==1) then - do k=1,nz - az(k) = sin(real(k-1, kind=mytype)*pi/two/ & - real(nz, kind=mytype)) - bz(k) = cos(real(k-1, kind=mytype)*pi/two/ & - real(nz, kind=mytype)) - end do - end if - - return - end subroutine abxyz - - ! *********************************************************** - ! - subroutine waves () - ! - !*********************************************************** - - use x3d_operator_x_data - use x3d_operator_y_data - use x3d_operator_z_data - use param - use variables - use decomp_2d_fft - use x3d_precision, only: pi, twopi - - implicit none - - integer :: i,j,k - real(mytype) :: w,wp,w1,w1p - complex(mytype) :: xyzk - complex(mytype) :: ytt,xtt,ztt,yt1,xt1,yt2,xt2 - complex(mytype) :: xtt1,ytt1,ztt1,zt1,zt2,tmp1,tmp2,tmp3 - complex(mytype) :: tmp4,tmp5,tmp6 - - real(mytype) :: rlexs - real(mytype) :: rleys - real(mytype) :: rlezs, iyezs - - real(mytype) :: ytt_rl,xtt_rl,ztt_rl,yt1_rl,xt1_rl,zt1_rl - real(mytype) :: xtt1_rl,ytt1_rl,ztt1_rl - - interface - pure function cx(realpart,imaginarypart) - use decomp_2d, only : mytype - implicit none - !$acc routine seq - complex(mytype) :: cx - real(mytype), intent(in) :: realpart, imaginarypart - end function cx - pure function rl(complexnumber) - use decomp_2d, only : mytype - implicit none - !$acc routine seq - complex(mytype), intent(in) :: complexnumber - real(mytype) :: rl - end function rl - pure function iy(complexnumber) - use decomp_2d, only : mytype - implicit none - !$acc routine seq - complex(mytype), intent(in) :: complexnumber - real(mytype) :: iy - end function iy - end interface - - xkx = zero - xk2 = zero - yky = zero - yk2 = zero - zkz = zero - zk2 = zero - - !WAVE NUMBER IN X - if (bcx == 0) then - do i = 1, nx/2 + 1 - w = twopi * (i-1) / nx - wp = acix6 * two * dx * sin(w * half) + bcix6 * two * dx * sin(three * half * w) - wp = wp / (one + two * alcaix6 * cos(w)) -! - xkx(i) = cx_one_one * (nx * wp / xlx) - exs(i) = cx_one_one * (nx * w / xlx) - xk2(i) = cx_one_one * (nx * wp / xlx)**2 -! - enddo - do i = nx/2 + 2, nx - xkx(i) = xkx(nx-i+2) - exs(i) = exs(nx-i+2) - xk2(i) = xk2(nx-i+2) - enddo - else - do i = 1, nx - w = twopi * half * (i-1) / nxm - wp = acix6 * two * dx * sin(w * half) +(bcix6 * two * dx) * sin(three * half * w) - wp = wp / (one + two * alcaix6 * cos(w)) -! - xkx(i) = cx_one_one * nxm * wp / xlx - exs(i) = cx_one_one * nxm * w / xlx - xk2(i) = cx_one_one * (nxm * wp / xlx)**2 -! - enddo - xkx(1) = zero - exs(1) = zero - xk2(1) = zero - endif -! - !WAVE NUMBER IN Y - if (bcy == 0) then - do j = 1, ny/2 + 1 - w = twopi * (j-1) / ny - wp = aciy6 * two * dy * sin(w * half) + bciy6 * two * dy * sin(three * half * w) - wp = wp / (one + two * alcaiy6 * cos(w)) -! - if (istret == 0) yky(j) = cx_one_one * (ny * wp / yly) - if (istret /= 0) yky(j) = cx_one_one * (ny * wp) - eys(j) = cx_one_one * (ny * w / yly) - yk2(j) = cx_one_one * (ny * wp / yly)**2 -! - enddo - do j = ny/2 + 2, ny - yky(j) = yky(ny-j+2) - eys(j) = eys(ny-j+2) - yk2(j) = yk2(ny-j+2) - enddo - else - do j = 1, ny - w = twopi * half * (j-1) / nym - wp = aciy6 * two * dy * sin(w * half) +(bciy6 * two *dy) * sin(three * half * w) - wp = wp / (one + two * alcaiy6 * cos(w)) -! - if (istret == 0) yky(j) = cx_one_one * (nym * wp / yly) - if (istret /= 0) yky(j) = cx_one_one * (nym * wp) - eys(j)=cx_one_one * (nym * w / yly) - yk2(j)=cx_one_one * (nym * wp / yly)**2 -! - enddo - yky(1) = zero - eys(1) = zero - yk2(1) = zero - endif - - !WAVE NUMBER IN Z - if (bcz == 0) then - do k = 1, nz/2 + 1 - w = twopi * (k-1) / nz - wp = aciz6 * two * dz * sin(w * half) + (bciz6 * two * dz) * sin(three * half * w) - wp = wp / (one + two * alcaiz6 * cos(w)) -! - zkz(k) = cx_one_one * (nz * wp / zlz) - ezs(k) = cx_one_one * (nz * w / zlz) - zk2(k) = cx_one_one * (nz * wp / zlz)**2 -! - enddo - else - do k= 1, nz/2 + 1 - w = pi * (k-1) / nzm - w1 = pi * (nzm-k+1) / nzm - wp = aciz6 * two * dz * sin(w * half)+(bciz6 * two * dz) * sin(three * half * w) - wp = wp / (one + two * alcaiz6 * cos(w)) - w1p = aciz6 * two * dz * sin(w1 * half) + (bciz6 * two * dz) * sin(three * half * w1) - w1p = w1p / (one + two * alcaiz6 * cos(w1)) -! - zkz(k) = cx(nzm * wp / zlz, -nzm * w1p / zlz) - ezs(k) = cx(nzm * w / zlz, nzm * w1 / zlz) - zk2(k) = cx((nzm * wp / zlz)**2, (nzm * w1p / zlz)**2) -! - enddo - endif - - if ((bcx == 0).and.(bcz == 0).and.(bcy /= 0)) then - - do concurrent (k=sp%yst(3):sp%yen(3), j=sp%yst(2):sp%yen(2), i=sp%yst(1):sp%yen(1)) - rlezs = rl(ezs(k)) * dz - rleys = rl(eys(j)) * dy - rlexs = rl(exs(i)) * dx -! - xtt_rl = two * & - (bicix6 * cos(rlexs * onepfive) + cicix6 * cos(rlexs * twopfive) + dicix6 * cos(rlexs * threepfive)) -! - ytt_rl = two * & - (biciy6 * cos(rleys * onepfive) + ciciy6 * cos(rleys * twopfive) + diciy6 * cos(rleys * threepfive)) -! - ztt_rl = two * & - (biciz6 * cos(rlezs * onepfive) + ciciz6 * cos(rlezs * twopfive) + diciz6 * cos(rlezs * threepfive)) -! - xtt1_rl = two * aicix6 * cos(rlexs * half) - ytt1_rl = two * aiciy6 * cos(rleys * half) - ztt1_rl = two * aiciz6 * cos(rlezs * half) + end do + end do + end do + + ! compute c2r transform + call decomp_2d_fft_3d(cw1, rhs) + + ! rhs is in Z-pencil but requires global operations in X + call x3d_transpose_z_to_y(rhs, rw2, ph) + call x3d_transpose_y_to_x(rw2, rw1, ph) + do k = ph%xst(3), ph%xen(3) + do j = ph%xst(2), ph%xen(2) + do i = 1, nx/2 + rw1b(2*i - 1, j, k) = rw1(i, j, k) + end do + do i = 1, nx/2 + rw1b(2*i, j, k) = rw1(nx - i + 1, j, k) + end do + end do + end do + call x3d_transpose_x_to_y(rw1b, rw2, ph) + call x3d_transpose_y_to_z(rw2, rhs, ph) + + ! call decomp_2d_fft_finalize + + return + end subroutine poisson_100 + + subroutine abxyz(ax, ay, az, bx, by, bz, nx, ny, nz, bcx, bcy, bcz) + + use param + use x3d_precision, only: pi + + implicit none + + integer, intent(IN) :: nx, ny, nz + integer, intent(IN) :: bcx, bcy, bcz + real(mytype), dimension(:), intent(OUT) :: ax, bx + real(mytype), dimension(:), intent(OUT) :: ay, by + real(mytype), dimension(:), intent(OUT) :: az, bz + + integer :: i, j, k + + if (bcx == 0) then + do i = 1, nx + ax(i) = sin(real(i - 1, kind=mytype)*pi/real(nx, kind=mytype)) + bx(i) = cos(real(i - 1, kind=mytype)*pi/real(nx, kind=mytype)) + end do + else if (bcx == 1) then + do i = 1, nx + ax(i) = sin(real(i - 1, kind=mytype)*pi/two/ & + real(nx, kind=mytype)) + bx(i) = cos(real(i - 1, kind=mytype)*pi/two/ & + real(nx, kind=mytype)) + end do + end if + + if (bcy == 0) then + do j = 1, ny + ay(j) = sin(real(j - 1, kind=mytype)*pi/real(ny, kind=mytype)) + by(j) = cos(real(j - 1, kind=mytype)*pi/real(ny, kind=mytype)) + end do + else if (bcy == 1) then + do j = 1, ny + ay(j) = sin(real(j - 1, kind=mytype)*pi/two/ & + real(ny, kind=mytype)) + by(j) = cos(real(j - 1, kind=mytype)*pi/two/ & + real(ny, kind=mytype)) + end do + end if + + if (bcz == 0) then + do k = 1, nz + az(k) = sin(real(k - 1, kind=mytype)*pi/real(nz, kind=mytype)) + bz(k) = cos(real(k - 1, kind=mytype)*pi/real(nz, kind=mytype)) + end do + else if (bcz == 1) then + do k = 1, nz + az(k) = sin(real(k - 1, kind=mytype)*pi/two/ & + real(nz, kind=mytype)) + bz(k) = cos(real(k - 1, kind=mytype)*pi/two/ & + real(nz, kind=mytype)) + end do + end if + + return + end subroutine abxyz + + ! *********************************************************** + ! + subroutine waves() + ! + !*********************************************************** + + use x3d_operator_x_data + use x3d_operator_y_data + use x3d_operator_z_data + use param + use variables + use decomp_2d_fft + use x3d_precision, only: pi, twopi + + implicit none + + integer :: i, j, k + real(mytype) :: w, wp, w1, w1p + complex(mytype) :: xyzk + complex(mytype) :: ytt, xtt, ztt, yt1, xt1, yt2, xt2 + complex(mytype) :: xtt1, ytt1, ztt1, zt1, zt2, tmp1, tmp2, tmp3 + complex(mytype) :: tmp4, tmp5, tmp6 + + real(mytype) :: rlexs + real(mytype) :: rleys + real(mytype) :: rlezs, iyezs + + real(mytype) :: ytt_rl, xtt_rl, ztt_rl, yt1_rl, xt1_rl, zt1_rl + real(mytype) :: xtt1_rl, ytt1_rl, ztt1_rl + + interface + pure function cx(realpart, imaginarypart) + use decomp_2d, only: mytype + implicit none + !$acc routine seq + complex(mytype) :: cx + real(mytype), intent(in) :: realpart, imaginarypart + end function cx + pure function rl(complexnumber) + use decomp_2d, only: mytype + implicit none + !$acc routine seq + complex(mytype), intent(in) :: complexnumber + real(mytype) :: rl + end function rl + pure function iy(complexnumber) + use decomp_2d, only: mytype + implicit none + !$acc routine seq + complex(mytype), intent(in) :: complexnumber + real(mytype) :: iy + end function iy + end interface + + xkx = zero + xk2 = zero + yky = zero + yk2 = zero + zkz = zero + zk2 = zero + + !WAVE NUMBER IN X + if (bcx == 0) then + do i = 1, nx/2 + 1 + w = twopi*(i - 1)/nx + wp = acix6*two*dx*sin(w*half) + bcix6*two*dx*sin(three*half*w) + wp = wp/(one + two*alcaix6*cos(w)) +! + xkx(i) = cx_one_one*(nx*wp/xlx) + exs(i) = cx_one_one*(nx*w/xlx) + xk2(i) = cx_one_one*(nx*wp/xlx)**2 +! + end do + do i = nx/2 + 2, nx + xkx(i) = xkx(nx - i + 2) + exs(i) = exs(nx - i + 2) + xk2(i) = xk2(nx - i + 2) + end do + else + do i = 1, nx + w = twopi*half*(i - 1)/nxm + wp = acix6*two*dx*sin(w*half) + (bcix6*two*dx)*sin(three*half*w) + wp = wp/(one + two*alcaix6*cos(w)) +! + xkx(i) = cx_one_one*nxm*wp/xlx + exs(i) = cx_one_one*nxm*w/xlx + xk2(i) = cx_one_one*(nxm*wp/xlx)**2 +! + end do + xkx(1) = zero + exs(1) = zero + xk2(1) = zero + end if +! + !WAVE NUMBER IN Y + if (bcy == 0) then + do j = 1, ny/2 + 1 + w = twopi*(j - 1)/ny + wp = aciy6*two*dy*sin(w*half) + bciy6*two*dy*sin(three*half*w) + wp = wp/(one + two*alcaiy6*cos(w)) +! + if (istret == 0) yky(j) = cx_one_one*(ny*wp/yly) + if (istret /= 0) yky(j) = cx_one_one*(ny*wp) + eys(j) = cx_one_one*(ny*w/yly) + yk2(j) = cx_one_one*(ny*wp/yly)**2 +! + end do + do j = ny/2 + 2, ny + yky(j) = yky(ny - j + 2) + eys(j) = eys(ny - j + 2) + yk2(j) = yk2(ny - j + 2) + end do + else + do j = 1, ny + w = twopi*half*(j - 1)/nym + wp = aciy6*two*dy*sin(w*half) + (bciy6*two*dy)*sin(three*half*w) + wp = wp/(one + two*alcaiy6*cos(w)) +! + if (istret == 0) yky(j) = cx_one_one*(nym*wp/yly) + if (istret /= 0) yky(j) = cx_one_one*(nym*wp) + eys(j) = cx_one_one*(nym*w/yly) + yk2(j) = cx_one_one*(nym*wp/yly)**2 +! + end do + yky(1) = zero + eys(1) = zero + yk2(1) = zero + end if + + !WAVE NUMBER IN Z + if (bcz == 0) then + do k = 1, nz/2 + 1 + w = twopi*(k - 1)/nz + wp = aciz6*two*dz*sin(w*half) + (bciz6*two*dz)*sin(three*half*w) + wp = wp/(one + two*alcaiz6*cos(w)) +! + zkz(k) = cx_one_one*(nz*wp/zlz) + ezs(k) = cx_one_one*(nz*w/zlz) + zk2(k) = cx_one_one*(nz*wp/zlz)**2 +! + end do + else + do k = 1, nz/2 + 1 + w = pi*(k - 1)/nzm + w1 = pi*(nzm - k + 1)/nzm + wp = aciz6*two*dz*sin(w*half) + (bciz6*two*dz)*sin(three*half*w) + wp = wp/(one + two*alcaiz6*cos(w)) + w1p = aciz6*two*dz*sin(w1*half) + (bciz6*two*dz)*sin(three*half*w1) + w1p = w1p/(one + two*alcaiz6*cos(w1)) +! + zkz(k) = cx(nzm*wp/zlz, -nzm*w1p/zlz) + ezs(k) = cx(nzm*w/zlz, nzm*w1/zlz) + zk2(k) = cx((nzm*wp/zlz)**2, (nzm*w1p/zlz)**2) +! + end do + end if + + if ((bcx == 0) .and. (bcz == 0) .and. (bcy /= 0)) then + + do concurrent(k=sp%yst(3):sp%yen(3), j=sp%yst(2):sp%yen(2), i=sp%yst(1):sp%yen(1)) + rlezs = rl(ezs(k))*dz + rleys = rl(eys(j))*dy + rlexs = rl(exs(i))*dx +! + xtt_rl = two* & + (bicix6*cos(rlexs*onepfive) + cicix6*cos(rlexs*twopfive) + dicix6*cos(rlexs*threepfive)) +! + ytt_rl = two* & + (biciy6*cos(rleys*onepfive) + ciciy6*cos(rleys*twopfive) + diciy6*cos(rleys*threepfive)) +! + ztt_rl = two* & + (biciz6*cos(rlezs*onepfive) + ciciz6*cos(rlezs*twopfive) + diciz6*cos(rlezs*threepfive)) +! + xtt1_rl = two*aicix6*cos(rlexs*half) + ytt1_rl = two*aiciy6*cos(rleys*half) + ztt1_rl = two*aiciz6*cos(rlezs*half) ! - xt1_rl = one + two * ailcaix6 * cos(rlexs) - yt1_rl = one + two * ailcaiy6 * cos(rleys) - zt1_rl = one + two * ailcaiz6 * cos(rlezs) + xt1_rl = one + two*ailcaix6*cos(rlexs) + yt1_rl = one + two*ailcaiy6*cos(rleys) + zt1_rl = one + two*ailcaiz6*cos(rlezs) ! - xt2 = xk2(i) * ((((ytt1_rl + ytt_rl) / yt1_rl) * ((ztt1_rl + ztt_rl) / zt1_rl))**2) - yt2 = yk2(j) * ((((xtt1_rl + xtt_rl) / xt1_rl) * ((ztt1_rl + ztt_rl) / zt1_rl))**2) - zt2 = zk2(k) * ((((xtt1_rl + xtt_rl) / xt1_rl) * ((ytt1_rl + ytt_rl) / yt1_rl))**2) + xt2 = xk2(i)*((((ytt1_rl + ytt_rl)/yt1_rl)*((ztt1_rl + ztt_rl)/zt1_rl))**2) + yt2 = yk2(j)*((((xtt1_rl + xtt_rl)/xt1_rl)*((ztt1_rl + ztt_rl)/zt1_rl))**2) + zt2 = zk2(k)*((((xtt1_rl + xtt_rl)/xt1_rl)*((ytt1_rl + ytt_rl)/yt1_rl))**2) ! - xyzk = xt2 + yt2 + zt2 - kxyz(i,j,k) = xyzk - enddo + xyzk = xt2 + yt2 + zt2 + kxyz(i, j, k) = xyzk + end do - else - if (bcz==0) then + else + if (bcz == 0) then - do concurrent (k=sp%xst(3):sp%xen(3), j=sp%xst(2):sp%xen(2), i=sp%xst(1):sp%xen(1)) - rlezs = rl(ezs(k)) * dz - rleys = rl(eys(j)) * dy - rlexs = rl(exs(i)) * dx + do concurrent(k=sp%xst(3):sp%xen(3), j=sp%xst(2):sp%xen(2), i=sp%xst(1):sp%xen(1)) + rlezs = rl(ezs(k))*dz + rleys = rl(eys(j))*dy + rlexs = rl(exs(i))*dx ! - xtt_rl = two * & - (bicix6 * cos(rlexs * onepfive) + cicix6 * cos(rlexs * twopfive) + dicix6 * cos(rlexs * threepfive)) + xtt_rl = two* & + (bicix6*cos(rlexs*onepfive) + cicix6*cos(rlexs*twopfive) + dicix6*cos(rlexs*threepfive)) ! - ytt_rl = two * & - (biciy6 * cos(rleys * onepfive) + ciciy6 * cos(rleys * twopfive) + diciy6 * cos(rleys * threepfive)) + ytt_rl = two* & + (biciy6*cos(rleys*onepfive) + ciciy6*cos(rleys*twopfive) + diciy6*cos(rleys*threepfive)) ! - ztt_rl = two * & - (biciz6 * cos(rlezs * onepfive) + ciciz6 * cos(rlezs * twopfive) + diciz6 * cos(rlezs * threepfive)) + ztt_rl = two* & + (biciz6*cos(rlezs*onepfive) + ciciz6*cos(rlezs*twopfive) + diciz6*cos(rlezs*threepfive)) ! - xtt1_rl = two * aicix6 * cos(rlexs * half) - ytt1_rl = two * aiciy6 * cos(rleys * half) - ztt1_rl = two * aiciz6 * cos(rlezs * half) + xtt1_rl = two*aicix6*cos(rlexs*half) + ytt1_rl = two*aiciy6*cos(rleys*half) + ztt1_rl = two*aiciz6*cos(rlezs*half) ! - xt1_rl = one + two * ailcaix6 * cos(rlexs) - yt1_rl = one + two * ailcaiy6 * cos(rleys) - zt1_rl = one + two * ailcaiz6 * cos(rlezs) + xt1_rl = one + two*ailcaix6*cos(rlexs) + yt1_rl = one + two*ailcaiy6*cos(rleys) + zt1_rl = one + two*ailcaiz6*cos(rlezs) ! - xt2 = xk2(i) * ((((ytt1_rl + ytt_rl) / yt1_rl) * ((ztt1_rl + ztt_rl) / zt1_rl))**2) - yt2 = yk2(j) * ((((xtt1_rl + xtt_rl) / xt1_rl) * ((ztt1_rl + ztt_rl) / zt1_rl))**2) - zt2 = zk2(k) * ((((xtt1_rl + xtt_rl) / xt1_rl) * ((ytt1_rl + ytt_rl) / yt1_rl))**2) + xt2 = xk2(i)*((((ytt1_rl + ytt_rl)/yt1_rl)*((ztt1_rl + ztt_rl)/zt1_rl))**2) + yt2 = yk2(j)*((((xtt1_rl + xtt_rl)/xt1_rl)*((ztt1_rl + ztt_rl)/zt1_rl))**2) + zt2 = zk2(k)*((((xtt1_rl + xtt_rl)/xt1_rl)*((ytt1_rl + ytt_rl)/yt1_rl))**2) ! - xyzk = xt2 + yt2 + zt2 - kxyz(i,j,k) = xyzk - enddo + xyzk = xt2 + yt2 + zt2 + kxyz(i, j, k) = xyzk + end do - else + else - do concurrent (k=sp%xst(3):sp%xen(3), j=sp%xst(2):sp%xen(2), i=sp%xst(1):sp%xen(1)) - rlezs = rl(ezs(k)) * dz - iyezs = iy(ezs(k)) * dz - rleys = rl(eys(j)) * dy - rlexs = rl(exs(i)) * dx + do concurrent(k=sp%xst(3):sp%xen(3), j=sp%xst(2):sp%xen(2), i=sp%xst(1):sp%xen(1)) + rlezs = rl(ezs(k))*dz + iyezs = iy(ezs(k))*dz + rleys = rl(eys(j))*dy + rlexs = rl(exs(i))*dx ! - xtt_rl = two * & - (bicix6 * cos(rlexs * onepfive) + cicix6 * cos(rlexs * twopfive) + dicix6 * cos(rlexs * threepfive)) + xtt_rl = two* & + (bicix6*cos(rlexs*onepfive) + cicix6*cos(rlexs*twopfive) + dicix6*cos(rlexs*threepfive)) ! - ytt_rl = two * & - (biciy6 * cos(rleys * onepfive) + ciciy6 * cos(rleys * twopfive) + diciy6 * cos(rleys * threepfive)) + ytt_rl = two* & + (biciy6*cos(rleys*onepfive) + ciciy6*cos(rleys*twopfive) + diciy6*cos(rleys*threepfive)) ! - ztt = two * cx( & - biciz6 * cos(rlezs * onepfive) + ciciz6 * cos(rlezs * twopfive) + diciz6 * cos(rlezs * threepfive),& - biciz6 * cos(iyezs * onepfive) + ciciz6 * cos(iyezs * twopfive) + diciz6 * cos(iyezs * threepfive)) + ztt = two*cx( & + biciz6*cos(rlezs*onepfive) + ciciz6*cos(rlezs*twopfive) + diciz6*cos(rlezs*threepfive), & + biciz6*cos(iyezs*onepfive) + ciciz6*cos(iyezs*twopfive) + diciz6*cos(iyezs*threepfive)) ! - xtt1_rl = two * aicix6 * cos(rlexs * half) - ytt1_rl = two * aiciy6 * cos(rleys * half) + xtt1_rl = two*aicix6*cos(rlexs*half) + ytt1_rl = two*aiciy6*cos(rleys*half) ! - ztt1 = two * cx(aiciz6 * cos(rlezs * half),& - aiciz6 * cos(iyezs * half)) + ztt1 = two*cx(aiciz6*cos(rlezs*half), & + aiciz6*cos(iyezs*half)) ! - xt1_rl = one + two * ailcaix6 * cos(rlexs) - yt1_rl = one + two * ailcaiy6 * cos(rleys) + xt1_rl = one + two*ailcaix6*cos(rlexs) + yt1_rl = one + two*ailcaiy6*cos(rleys) ! - zt1 = cx((one + two * ailcaiz6 * cos(rlezs)),& - (one + two * ailcaiz6 * cos(iyezs))) + zt1 = cx((one + two*ailcaiz6*cos(rlezs)), & + (one + two*ailcaiz6*cos(iyezs))) ! - tmp1 = cx(rl(ztt1 + ztt) / rl(zt1),& - iy(ztt1 + ztt) / iy(zt1)) + tmp1 = cx(rl(ztt1 + ztt)/rl(zt1), & + iy(ztt1 + ztt)/iy(zt1)) ! - tmp2 = cx_one_one * (ytt1_rl + ytt_rl) / yt1_rl + tmp2 = cx_one_one*(ytt1_rl + ytt_rl)/yt1_rl ! - tmp3 = cx_one_one * (xtt1_rl + xtt_rl) / xt1_rl + tmp3 = cx_one_one*(xtt1_rl + xtt_rl)/xt1_rl ! - tmp4 = rl(tmp2)**2 * cx(rl(tmp1)**2, iy(tmp1)**2) + tmp4 = rl(tmp2)**2*cx(rl(tmp1)**2, iy(tmp1)**2) ! - tmp5 = rl(tmp3)**2 * cx(rl(tmp1)**2, iy(tmp1)**2) + tmp5 = rl(tmp3)**2*cx(rl(tmp1)**2, iy(tmp1)**2) ! - tmp6 = (rl(tmp3) * rl(tmp2))**2 * cx_one_one + tmp6 = (rl(tmp3)*rl(tmp2))**2*cx_one_one ! - tmp1 = cx(rl(tmp4) * rl(xk2(i)), iy(tmp4) * iy(xk2(i))) + tmp1 = cx(rl(tmp4)*rl(xk2(i)), iy(tmp4)*iy(xk2(i))) ! - tmp2 = cx(rl(tmp5) * rl(yk2(j)), iy(tmp5) * iy(yk2(j))) + tmp2 = cx(rl(tmp5)*rl(yk2(j)), iy(tmp5)*iy(yk2(j))) ! - tmp3 = rl(tmp6) * zk2(k) + tmp3 = rl(tmp6)*zk2(k) ! - xyzk = tmp1 + tmp2 + tmp3 - kxyz(i,j,k) = xyzk - enddo + xyzk = tmp1 + tmp2 + tmp3 + kxyz(i, j, k) = xyzk + end do - endif - endif + end if + end if - return - end subroutine waves + return + end subroutine waves end module decomp_2d_poisson diff --git a/src/thomas.f90 b/src/thomas.f90 index a0a2fb6..3e59822 100644 --- a/src/thomas.f90 +++ b/src/thomas.f90 @@ -4,201 +4,200 @@ module thomas - use decomp_2d, only : mytype - use param, only : zero, one + use decomp_2d, only: mytype + use param, only: zero, one - implicit none + implicit none - private - public :: xthomas, ythomas, zthomas, thomas1d + private + public :: xthomas, ythomas, zthomas, thomas1d - interface xthomas - module procedure xthomas_0 - module procedure xthomas_12 - end interface xthomas + interface xthomas + module procedure xthomas_0 + module procedure xthomas_12 + end interface xthomas - interface ythomas - module procedure ythomas_0 - module procedure ythomas_12 - end interface ythomas - - interface zthomas - module procedure zthomas_0 - module procedure zthomas_12 - end interface zthomas + interface ythomas + module procedure ythomas_0 + module procedure ythomas_12 + end interface ythomas + interface zthomas + module procedure zthomas_0 + module procedure zthomas_12 + end interface zthomas contains - ! Thomas algorithm in X direction (periodicity) - pure subroutine xthomas_0(tt, ff, fs, fw, perio, alfa, nx, ny, nz) + ! Thomas algorithm in X direction (periodicity) + pure subroutine xthomas_0(tt, ff, fs, fw, perio, alfa, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(inout), dimension(nx,ny,nz) :: tt - real(mytype), intent(in), dimension(nx):: ff, fs, fw, perio - real(mytype), intent(in) :: alfa + integer, intent(in) :: nx, ny, nz + real(mytype), intent(inout), dimension(nx, ny, nz) :: tt + real(mytype), intent(in), dimension(nx):: ff, fs, fw, perio + real(mytype), intent(in) :: alfa - integer :: i, j, k - real(mytype) :: ss + integer :: i, j, k + real(mytype) :: ss - call xthomas_12(tt, ff, fs, fw, nx, ny, nz) - do concurrent (k=1:nz, j=1:ny) - ss = ( tt(1,j,k)-alfa*tt(nx,j,k)) & - / (one+perio(1)-alfa*perio(nx)) - do i = 1, nx - tt(i,j,k) = tt(i,j,k) - ss*perio(i) - enddo - enddo + call xthomas_12(tt, ff, fs, fw, nx, ny, nz) + do concurrent(k=1:nz, j=1:ny) + ss = (tt(1, j, k) - alfa*tt(nx, j, k)) & + /(one + perio(1) - alfa*perio(nx)) + do i = 1, nx + tt(i, j, k) = tt(i, j, k) - ss*perio(i) + end do + end do - end subroutine xthomas_0 + end subroutine xthomas_0 - ! Thomas algorithm in X direction - pure subroutine xthomas_12(tt, ff, fs, fw, nx, ny, nz) + ! Thomas algorithm in X direction + pure subroutine xthomas_12(tt, ff, fs, fw, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(inout), dimension(nx,ny,nz) :: tt - real(mytype), intent(in), dimension(nx):: ff, fs, fw + integer, intent(in) :: nx, ny, nz + real(mytype), intent(inout), dimension(nx, ny, nz) :: tt + real(mytype), intent(in), dimension(nx):: ff, fs, fw - integer :: i, j, k + integer :: i, j, k - do concurrent (k=1:nz, j=1:ny) - do i = 2, nx - tt(i,j,k) = tt(i,j,k) - tt(i-1,j,k)*fs(i) - enddo - tt(nx,j,k) = tt(nx,j,k) * fw(nx) - do i=nx-1,1,-1 - tt(i,j,k) = (tt(i,j,k)-ff(i)*tt(i+1,j,k)) * fw(i) - enddo - enddo + do concurrent(k=1:nz, j=1:ny) + do i = 2, nx + tt(i, j, k) = tt(i, j, k) - tt(i - 1, j, k)*fs(i) + end do + tt(nx, j, k) = tt(nx, j, k)*fw(nx) + do i = nx - 1, 1, -1 + tt(i, j, k) = (tt(i, j, k) - ff(i)*tt(i + 1, j, k))*fw(i) + end do + end do - end subroutine xthomas_12 + end subroutine xthomas_12 - ! Thomas algorithm in Y direction (periodicity) - subroutine ythomas_0(tt, ff, fs, fw, perio, alfa, nx, ny, nz) + ! Thomas algorithm in Y direction (periodicity) + subroutine ythomas_0(tt, ff, fs, fw, perio, alfa, nx, ny, nz) - implicit none - - integer, intent(in) :: nx, ny, nz - real(mytype), intent(inout), dimension(nx,ny,nz) :: tt - real(mytype), intent(in), dimension(ny):: ff, fs, fw, perio - real(mytype), intent(in) :: alfa + implicit none + + integer, intent(in) :: nx, ny, nz + real(mytype), intent(inout), dimension(nx, ny, nz) :: tt + real(mytype), intent(in), dimension(ny):: ff, fs, fw, perio + real(mytype), intent(in) :: alfa - integer :: i, j, k - real(mytype) :: ss + integer :: i, j, k + real(mytype) :: ss - call ythomas_12(tt, ff, fs, fw, nx, ny, nz) - do concurrent (k=1:nz, i=1:nx) - ss = ( tt(i,1,k)-alfa*tt(i,ny,k)) & - / (one+perio(1)-alfa*perio(ny)) - do j = 1, ny - tt(i,j,k) = tt(i,j,k) - ss*perio(j) - enddo - enddo + call ythomas_12(tt, ff, fs, fw, nx, ny, nz) + do concurrent(k=1:nz, i=1:nx) + ss = (tt(i, 1, k) - alfa*tt(i, ny, k)) & + /(one + perio(1) - alfa*perio(ny)) + do j = 1, ny + tt(i, j, k) = tt(i, j, k) - ss*perio(j) + end do + end do - end subroutine ythomas_0 + end subroutine ythomas_0 - ! Thomas algorithm in Y direction - subroutine ythomas_12(tt, ff, fs, fw, nx, ny, nz) + ! Thomas algorithm in Y direction + subroutine ythomas_12(tt, ff, fs, fw, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(inout), dimension(nx,ny,nz) :: tt - real(mytype), intent(in), dimension(ny):: ff, fs, fw + integer, intent(in) :: nx, ny, nz + real(mytype), intent(inout), dimension(nx, ny, nz) :: tt + real(mytype), intent(in), dimension(ny):: ff, fs, fw - integer :: i, j, k + integer :: i, j, k - do concurrent (k=1:nz, i=1:nx) - do j=2,ny - tt(i,j,k) = tt(i,j,k) - tt(i,j-1,k)*fs(j) - enddo - tt(i,ny,k) = tt(i,ny,k) * fw(ny) - do j=ny-1,1,-1 - tt(i,j,k) = (tt(i,j,k)-ff(j)*tt(i,j+1,k)) * fw(j) - enddo - enddo + do concurrent(k=1:nz, i=1:nx) + do j = 2, ny + tt(i, j, k) = tt(i, j, k) - tt(i, j - 1, k)*fs(j) + end do + tt(i, ny, k) = tt(i, ny, k)*fw(ny) + do j = ny - 1, 1, -1 + tt(i, j, k) = (tt(i, j, k) - ff(j)*tt(i, j + 1, k))*fw(j) + end do + end do - end subroutine ythomas_12 + end subroutine ythomas_12 - ! Thomas algorithm in Z direction (periodicity) - subroutine zthomas_0(tt, ff, fs, fw, perio, alfa, nx, ny, nz) + ! Thomas algorithm in Z direction (periodicity) + subroutine zthomas_0(tt, ff, fs, fw, perio, alfa, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(inout), dimension(nx,ny,nz) :: tt - real(mytype), intent(in), dimension(nz):: ff, fs, fw, perio - real(mytype), intent(in) :: alfa - - integer :: i, j, k - real(mytype) :: ss - - call zthomas_12(tt, ff, fs, fw, nx, ny, nz) - do concurrent (j=1:ny, i=1:nx) - ss = ( tt(i,j,1)-alfa*tt(i,j,nz)) & - / (one+perio(1)-alfa*perio(nz)) - do k=1,nz - tt(i,j,k) = tt(i,j,k) - ss*perio(k) - enddo - enddo - - end subroutine zthomas_0 - - ! Thomas algorithm in Z direction - subroutine zthomas_12(tt, ff, fs, fw, nx, ny, nz) + integer, intent(in) :: nx, ny, nz + real(mytype), intent(inout), dimension(nx, ny, nz) :: tt + real(mytype), intent(in), dimension(nz):: ff, fs, fw, perio + real(mytype), intent(in) :: alfa + + integer :: i, j, k + real(mytype) :: ss + + call zthomas_12(tt, ff, fs, fw, nx, ny, nz) + do concurrent(j=1:ny, i=1:nx) + ss = (tt(i, j, 1) - alfa*tt(i, j, nz)) & + /(one + perio(1) - alfa*perio(nz)) + do k = 1, nz + tt(i, j, k) = tt(i, j, k) - ss*perio(k) + end do + end do + + end subroutine zthomas_0 + + ! Thomas algorithm in Z direction + subroutine zthomas_12(tt, ff, fs, fw, nx, ny, nz) - implicit none - - integer, intent(in) :: nx, ny, nz - real(mytype), intent(inout), dimension(nx,ny,nz) :: tt - real(mytype), intent(in), dimension(nz):: ff, fs, fw - - integer :: i, j, k - - do concurrent (j=1:ny, i=1:nx) - do k=2,nz - tt(i,j,k) = tt(i,j,k) - tt(i,j,k-1)*fs(k) - enddo - tt(i,j,nz) = tt(i,j,nz) * fw(nz) - do k=nz-1,1,-1 - tt(i,j,k) = (tt(i,j,k)-ff(k)*tt(i,j,k+1)) * fw(k) - enddo - enddo - - end subroutine zthomas_12 - - ! - ! Thomas algorithm for a 1D vector (solve My = x with tri-diagonal M) - ! See comments in the subroutine prepare (x3d_operator_1d.f90) - ! - ! tt, inout, vector x and y - ! ff, in, upper diagonal of the tri-diagonal matrix - ! fs, in, used during the forward step - ! fw, in, used during the backward step - ! nn, in, size of the vector - ! - pure subroutine thomas1d(tt, ff, fs, fw, nn) - - implicit none - - integer, intent(in) :: nn - real(mytype), intent(inout), dimension(nn) :: tt - real(mytype), intent(in), dimension(nn) :: ff, fs, fw - - integer :: k - - do k = 2, nn - tt(k) = tt(k) - tt(k-1)*fs(k) - enddo - tt(nn) = tt(nn) * fw(nn) - do k = nn-1, 1, -1 - tt(k) = (tt(k)-ff(k)*tt(k+1)) * fw(k) - enddo + implicit none + + integer, intent(in) :: nx, ny, nz + real(mytype), intent(inout), dimension(nx, ny, nz) :: tt + real(mytype), intent(in), dimension(nz):: ff, fs, fw + + integer :: i, j, k + + do concurrent(j=1:ny, i=1:nx) + do k = 2, nz + tt(i, j, k) = tt(i, j, k) - tt(i, j, k - 1)*fs(k) + end do + tt(i, j, nz) = tt(i, j, nz)*fw(nz) + do k = nz - 1, 1, -1 + tt(i, j, k) = (tt(i, j, k) - ff(k)*tt(i, j, k + 1))*fw(k) + end do + end do + + end subroutine zthomas_12 + + ! + ! Thomas algorithm for a 1D vector (solve My = x with tri-diagonal M) + ! See comments in the subroutine prepare (x3d_operator_1d.f90) + ! + ! tt, inout, vector x and y + ! ff, in, upper diagonal of the tri-diagonal matrix + ! fs, in, used during the forward step + ! fw, in, used during the backward step + ! nn, in, size of the vector + ! + pure subroutine thomas1d(tt, ff, fs, fw, nn) + + implicit none + + integer, intent(in) :: nn + real(mytype), intent(inout), dimension(nn) :: tt + real(mytype), intent(in), dimension(nn) :: ff, fs, fw + + integer :: k + + do k = 2, nn + tt(k) = tt(k) - tt(k - 1)*fs(k) + end do + tt(nn) = tt(nn)*fw(nn) + do k = nn - 1, 1, -1 + tt(k) = (tt(k) - ff(k)*tt(k + 1))*fw(k) + end do - end subroutine thomas1d + end subroutine thomas1d end module thomas diff --git a/src/time_integrators.f90 b/src/time_integrators.f90 index 75568bd..224a3e8 100644 --- a/src/time_integrators.f90 +++ b/src/time_integrators.f90 @@ -4,176 +4,173 @@ module time_integrators - use param, only : itr, ntime, gdt - use variables - use decomp_2d, only : mytype, xsize, nrank + use param, only: itr, ntime, gdt + use variables + use decomp_2d, only: mytype, xsize, nrank - implicit none + implicit none - private - public :: int_time + private + public :: int_time contains - subroutine intt(var1,dvar1) - - use MPI - - implicit none - - !! INPUT / OUTPUT - real(mytype),dimension(xsize(1),xsize(2),xsize(3)) :: var1 - real(mytype),dimension(xsize(1),xsize(2),xsize(3),ntime) :: dvar1 - - !! LOCAL - integer :: i,j,k - - - ! for the moment we just use euler - do concurrent (k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) - var1(i,j,k)=gdt(itr)*dvar1(i,j,k,1)+var1(i,j,k) - enddo - - !if (iimplicit.ge.1) then - ! !>>> (semi)implicit Y diffusion - - ! if (present(isc)) then - ! is = isc - ! else - ! is = 0 - ! endif - ! if (present(npaire).and.present(forcing1)) then - ! call inttimp(var1, dvar1, npaire=npaire, isc=is, forcing1=forcing1) - ! else if (present(npaire)) then - ! call inttimp(var1, dvar1, npaire=npaire, isc=is) - ! else - ! if (nrank == 0) write(*,*) "Error in intt call." - ! call MPI_ABORT(MPI_COMM_WORLD,code,ierror); stop - ! endif - - !elseif (itimescheme.eq.1) then - ! !>>> Euler - - ! var1(:,:,:)=gdt(itr)*dvar1(:,:,:,1)+var1(:,:,:) - !elseif(itimescheme.eq.2) then - ! !>>> Adam-Bashforth second order (AB2) - - ! ! Do first time step with Euler - ! if(itime.eq.1.and.irestart.eq.0) then - ! var1(:,:,:)=gdt(itr)*dvar1(:,:,:,1)+var1(:,:,:) - ! else - ! var1(:,:,:)=adt(itr)*dvar1(:,:,:,1)+bdt(itr)*dvar1(:,:,:,2)+var1(:,:,:) - ! endif - ! dvar1(:,:,:,2)=dvar1(:,:,:,1) - !elseif(itimescheme.eq.3) then - ! !>>> Adams-Bashforth third order (AB3) - - ! ! Do first time step with Euler - ! if(itime.eq.1.and.irestart.eq.0) then - ! var1(:,:,:)=dt*dvar1(:,:,:,1)+var1(:,:,:) - ! elseif(itime.eq.2.and.irestart.eq.0) then - ! ! Do second time step with AB2 - ! var1(:,:,:)=onepfive*dt*dvar1(:,:,:,1)-half*dt*dvar1(:,:,:,2)+var1(:,:,:) - ! dvar1(:,:,:,3)=dvar1(:,:,:,2) - ! else - ! ! Finally using AB3 - ! var1(:,:,:)=adt(itr)*dvar1(:,:,:,1)+bdt(itr)*dvar1(:,:,:,2)+cdt(itr)*dvar1(:,:,:,3)+var1(:,:,:) - ! dvar1(:,:,:,3)=dvar1(:,:,:,2) - ! endif - ! dvar1(:,:,:,2)=dvar1(:,:,:,1) - !elseif(itimescheme.eq.4) then - ! !>>> Adams-Bashforth fourth order (AB4) - - ! if (nrank==0) then - ! write(*,*) "AB4 not implemented!" - ! stop - ! endif - - ! !>>> Runge-Kutta (low storage) RK3 - !elseif(itimescheme.eq.5) then - ! if(itr.eq.1) then - ! var1(:,:,:)=gdt(itr)*dvar1(:,:,:,1)+var1(:,:,:) - ! else - ! var1(:,:,:)=adt(itr)*dvar1(:,:,:,1)+bdt(itr)*dvar1(:,:,:,2)+var1(:,:,:) - ! endif - ! dvar1(:,:,:,2)=dvar1(:,:,:,1) - ! !>>> Runge-Kutta (low storage) RK4 - !elseif(itimescheme.eq.6) then - - ! if (nrank==0) then - ! write(*,*) "RK4 not implemented!" - ! STOP - ! endif - - !else - - ! if (nrank==0) then - ! write(*,*) "Unrecognised itimescheme: ", itimescheme - ! STOP - ! endif - - !endif - - - return - - end subroutine intt + subroutine intt(var1, dvar1) + + use MPI + + implicit none + + ! INPUT / OUTPUT + real(mytype), dimension(xsize(1), xsize(2), xsize(3)) :: var1 + real(mytype), dimension(xsize(1), xsize(2), xsize(3), ntime) :: dvar1 + + ! LOCAL + integer :: i, j, k + + ! for the moment we just use euler + do concurrent(k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) + var1(i, j, k) = gdt(itr)*dvar1(i, j, k, 1) + var1(i, j, k) + end do + + !if (iimplicit.ge.1) then + ! !>>> (semi)implicit Y diffusion + + ! if (present(isc)) then + ! is = isc + ! else + ! is = 0 + ! endif + ! if (present(npaire).and.present(forcing1)) then + ! call inttimp(var1, dvar1, npaire=npaire, isc=is, forcing1=forcing1) + ! else if (present(npaire)) then + ! call inttimp(var1, dvar1, npaire=npaire, isc=is) + ! else + ! if (nrank == 0) write(*,*) "Error in intt call." + ! call MPI_ABORT(MPI_COMM_WORLD,code,ierror); stop + ! endif + + !elseif (itimescheme.eq.1) then + ! !>>> Euler + + ! var1(:,:,:)=gdt(itr)*dvar1(:,:,:,1)+var1(:,:,:) + !elseif(itimescheme.eq.2) then + ! !>>> Adam-Bashforth second order (AB2) + + ! ! Do first time step with Euler + ! if(itime.eq.1.and.irestart.eq.0) then + ! var1(:,:,:)=gdt(itr)*dvar1(:,:,:,1)+var1(:,:,:) + ! else + ! var1(:,:,:)=adt(itr)*dvar1(:,:,:,1)+bdt(itr)*dvar1(:,:,:,2)+var1(:,:,:) + ! endif + ! dvar1(:,:,:,2)=dvar1(:,:,:,1) + !elseif(itimescheme.eq.3) then + ! !>>> Adams-Bashforth third order (AB3) + + ! ! Do first time step with Euler + ! if(itime.eq.1.and.irestart.eq.0) then + ! var1(:,:,:)=dt*dvar1(:,:,:,1)+var1(:,:,:) + ! elseif(itime.eq.2.and.irestart.eq.0) then + ! ! Do second time step with AB2 + ! var1(:,:,:)=onepfive*dt*dvar1(:,:,:,1)-half*dt*dvar1(:,:,:,2)+var1(:,:,:) + ! dvar1(:,:,:,3)=dvar1(:,:,:,2) + ! else + ! ! Finally using AB3 + ! var1(:,:,:)=adt(itr)*dvar1(:,:,:,1)+bdt(itr)*dvar1(:,:,:,2)+cdt(itr)*dvar1(:,:,:,3)+var1(:,:,:) + ! dvar1(:,:,:,3)=dvar1(:,:,:,2) + ! endif + ! dvar1(:,:,:,2)=dvar1(:,:,:,1) + !elseif(itimescheme.eq.4) then + ! !>>> Adams-Bashforth fourth order (AB4) + + ! if (nrank==0) then + ! write(*,*) "AB4 not implemented!" + ! stop + ! endif + + ! !>>> Runge-Kutta (low storage) RK3 + !elseif(itimescheme.eq.5) then + ! if(itr.eq.1) then + ! var1(:,:,:)=gdt(itr)*dvar1(:,:,:,1)+var1(:,:,:) + ! else + ! var1(:,:,:)=adt(itr)*dvar1(:,:,:,1)+bdt(itr)*dvar1(:,:,:,2)+var1(:,:,:) + ! endif + ! dvar1(:,:,:,2)=dvar1(:,:,:,1) + ! !>>> Runge-Kutta (low storage) RK4 + !elseif(itimescheme.eq.6) then + + ! if (nrank==0) then + ! write(*,*) "RK4 not implemented!" + ! STOP + ! endif + + !else + + ! if (nrank==0) then + ! write(*,*) "Unrecognised itimescheme: ", itimescheme + ! STOP + ! endif + + !endif + + return + + end subroutine intt !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! - !! SUBROUTINE: int_time - !! DESCRIPTION: - !! INPUTS: - !! OUTPUTS: - !! NOTES: - !! AUTHOR: - !! + ! + ! SUBROUTINE: int_time + ! DESCRIPTION: + ! INPUTS: + ! OUTPUTS: + ! NOTES: + ! AUTHOR: + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine int_time(ux1, uy1, uz1, dux1, duy1, duz1) + subroutine int_time(ux1, uy1, uz1, dux1, duy1, duz1) - implicit none + implicit none - !! input/output - real(mytype), dimension(xsize(1), xsize(2), xsize(3), ntime) :: dux1, duy1, duz1 + ! input/output + real(mytype), dimension(xsize(1), xsize(2), xsize(3), ntime) :: dux1, duy1, duz1 - !! output - real(mytype), dimension(xsize(1), xsize(2), xsize(3)) :: ux1, uy1, uz1 + ! output + real(mytype), dimension(xsize(1), xsize(2), xsize(3)) :: ux1, uy1, uz1 - !! LOCAL + ! LOCAL #ifdef DEBUG - real(mytype) avg_param - if (nrank .eq. 0) write(*,*)'## Init int_time' + real(mytype) avg_param + if (nrank == 0) write (*, *) '## Init int_time' #endif - call int_time_momentum(ux1, uy1, uz1, dux1, duy1, duz1) + call int_time_momentum(ux1, uy1, uz1, dux1, duy1, duz1) - - ENDSUBROUTINE int_time + END SUBROUTINE int_time !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! - !! SUBROUTINE: int_time_momentum - !! DESCRIPTION: Integrates the momentum equations in time by calling time - !! integrator. - !! INPUTS: dux1, duy1, duz1 - the RHS(s) of the momentum equations - !! OUTPUTS: ux1, uy1, uz1 - the intermediate momentum state. - !! NOTES: This is integrating the MOMENTUM in time (!= velocity) - !! + ! + ! SUBROUTINE: int_time_momentum + ! DESCRIPTION: Integrates the momentum equations in time by calling time + ! integrator. + ! INPUTS: dux1, duy1, duz1 - the RHS(s) of the momentum equations + ! OUTPUTS: ux1, uy1, uz1 - the intermediate momentum state. + ! NOTES: This is integrating the MOMENTUM in time (!= velocity) + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine int_time_momentum(ux1, uy1, uz1, dux1, duy1, duz1) + subroutine int_time_momentum(ux1, uy1, uz1, dux1, duy1, duz1) - implicit none + implicit none - !! INPUTS - real(mytype),dimension(xsize(1),xsize(2),xsize(3)) :: ux1, uy1, uz1 + ! INPUTS + real(mytype), dimension(xsize(1), xsize(2), xsize(3)) :: ux1, uy1, uz1 - !! OUTPUTS - real(mytype),dimension(xsize(1),xsize(2),xsize(3),ntime) :: dux1, duy1, duz1 + ! OUTPUTS + real(mytype), dimension(xsize(1), xsize(2), xsize(3), ntime) :: dux1, duy1, duz1 - call intt(ux1, dux1) - call intt(uy1, duy1) - call intt(uz1, duz1) + call intt(ux1, dux1) + call intt(uy1, duy1) + call intt(uz1, duz1) - endsubroutine int_time_momentum + end subroutine int_time_momentum end module time_integrators diff --git a/src/tools.f90 b/src/tools.f90 index eabdb4e..2e899b0 100644 --- a/src/tools.f90 +++ b/src/tools.f90 @@ -4,75 +4,75 @@ module tools - use decomp_2d, only : mytype, real_type, xsize, decomp_2d_abort - use variables, only : nx, ny, nz - use param, only : zero + use decomp_2d, only: mytype, real_type, xsize, decomp_2d_abort + use variables, only: nx, ny, nz + use param, only: zero - implicit none + implicit none - private + private - public :: error_l1_l2_linf + public :: error_l1_l2_linf - interface error_l1_l2_linf - module procedure error_l1_l2_linf_xsize - module procedure error_l1_l2_linf_generic - end interface error_l1_l2_linf + interface error_l1_l2_linf + module procedure error_l1_l2_linf_xsize + module procedure error_l1_l2_linf_generic + end interface error_l1_l2_linf contains - !################################################################## - !################################################################## - subroutine error_L1_L2_Linf_xsize(err, l1, l2, linf) + !################################################################## + !################################################################## + subroutine error_L1_L2_Linf_xsize(err, l1, l2, linf) - implicit none + implicit none - real(mytype),intent(in),dimension(xsize(1),xsize(2),xsize(3)) :: err - real(mytype),intent(out) :: l1, l2, linf + real(mytype), intent(in), dimension(xsize(1), xsize(2), xsize(3)) :: err + real(mytype), intent(out) :: l1, l2, linf - call error_L1_L2_Linf_generic(err, l1, l2, linf, xsize(1), xsize(2), xsize(3), nx*ny*nz) + call error_L1_L2_Linf_generic(err, l1, l2, linf, xsize(1), xsize(2), xsize(3), nx*ny*nz) - end subroutine error_L1_L2_Linf_xsize - !################################################################## + end subroutine error_L1_L2_Linf_xsize + !################################################################## - !################################################################## - subroutine error_L1_L2_Linf_generic(err, l1, l2, linf, n1, n2, n3, ntot) + !################################################################## + subroutine error_L1_L2_Linf_generic(err, l1, l2, linf, n1, n2, n3, ntot) - ! Compute L1, L2 and Linf norm of given 3D array - USE MPI + ! Compute L1, L2 and Linf norm of given 3D array + USE MPI - implicit none + implicit none - real(mytype),intent(in),dimension(n1,n2,n3) :: err - real(mytype),intent(out) :: l1, l2, linf - integer, intent(in) :: n1, n2, n3, ntot + real(mytype), intent(in), dimension(n1, n2, n3) :: err + real(mytype), intent(out) :: l1, l2, linf + integer, intent(in) :: n1, n2, n3, ntot - integer :: i, j, k, code - real(mytype) :: l1l2(2) + integer :: i, j, k, code + real(mytype) :: l1l2(2) - l1 = zero - l2 = zero - linf = zero + l1 = zero + l2 = zero + linf = zero - do k = 1,n3 - do j = 1,n2 - do i = 1,n1 - l1 = l1 + abs(err(i,j,k)) - l2 = l2 + err(i,j,k)*err(i,j,k) - linf = max(linf, abs(err(i,j,k))) - enddo - enddo - enddo + do k = 1, n3 + do j = 1, n2 + do i = 1, n1 + l1 = l1 + abs(err(i, j, k)) + l2 = l2 + err(i, j, k)*err(i, j, k) + linf = max(linf, abs(err(i, j, k))) + end do + end do + end do - ! Parallel, MPI_SUM - l1l2 = (/l1, l2/) - code = 0 - call MPI_ALLREDUCE(MPI_IN_PLACE,l1l2,2,real_type,MPI_SUM,MPI_COMM_WORLD,code) - if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, "MPI_ALLREDUCE") - l1 = l1l2(1) / ntot - l2 = sqrt(l1l2(2) / ntot) - ! Parallel, MPI_MAX - call MPI_ALLREDUCE(MPI_IN_PLACE,linf,1,real_type,MPI_MAX,MPI_COMM_WORLD,code) - if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, "MPI_ALLREDUCE") + ! Parallel, MPI_SUM + l1l2 = (/l1, l2/) + code = 0 + call MPI_ALLREDUCE(MPI_IN_PLACE, l1l2, 2, real_type, MPI_SUM, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, "MPI_ALLREDUCE") + l1 = l1l2(1)/ntot + l2 = sqrt(l1l2(2)/ntot) + ! Parallel, MPI_MAX + call MPI_ALLREDUCE(MPI_IN_PLACE, linf, 1, real_type, MPI_MAX, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, "MPI_ALLREDUCE") - end subroutine error_L1_L2_Linf_generic + end subroutine error_L1_L2_Linf_generic end module tools diff --git a/src/transeq.f90 b/src/transeq.f90 index b1078c4..59638b0 100644 --- a/src/transeq.f90 +++ b/src/transeq.f90 @@ -4,237 +4,236 @@ module transeq - private - public :: calculate_transeq_rhs + private + public :: calculate_transeq_rhs contains - !############################################################################ - !! SUBROUTINE: calculate_transeq_rhs - !! DESCRIPTION: Calculates the right hand sides of all transport - !! equations - momentum, scalar transport, etc. - !############################################################################ - subroutine calculate_transeq_rhs(dux1,duy1,duz1,ux1,uy1,uz1) - - use decomp_2d, only : mytype - use decomp_2d, only : xsize, zsize - use param, only : ntime - - implicit none - - !! Inputs - real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: ux1, uy1, uz1 - - !! Outputs - real(mytype), dimension(xsize(1), xsize(2), xsize(3), ntime) :: dux1, duy1, duz1 - - !! Momentum equations - call momentum_rhs_eq(dux1,duy1,duz1,ux1,uy1,uz1) - - end subroutine calculate_transeq_rhs - !############################################################################ - !############################################################################ - !! - !! subroutine: momentum_rhs_eq - !! DESCRIPTION: Calculation of convective and diffusion terms of momentum - !! equation - !! - !############################################################################ - !############################################################################ - subroutine momentum_rhs_eq(dux1,duy1,duz1,ux1,uy1,uz1) - - use param - use variables - use x3d_operator_1d - use decomp_2d, only : mytype - use x3d_transpose - use x3d_derive - use decomp_2d , only : xsize, ysize, zsize - use var, only : ta1,tb1,tc1,td1,te1,tf1,tg1,th1,ti1 - use var, only : ux2,uy2,uz2,ta2,tb2,tc2,td2,te2,tf2,tg2,th2,ti2,tj2 - use var, only : ux3,uy3,uz3,ta3,tb3,tc3,td3,te3,tf3,tg3,th3,ti3 - use case, only : case_forcing - - implicit none - - !! INPUTS - real(mytype),dimension(xsize(1),xsize(2),xsize(3)) :: ux1,uy1,uz1 - - !! OUTPUTS - real(mytype),dimension(xsize(1),xsize(2),xsize(3),ntime) :: dux1,duy1,duz1 - - - integer :: i,j,k,is - - !SKEW SYMMETRIC FORM - !WORK X-PENCILS - - do concurrent (k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) - ta1(i,j,k) = ux1(i,j,k) * ux1(i,j,k) - tb1(i,j,k) = ux1(i,j,k) * uy1(i,j,k) - tc1(i,j,k) = ux1(i,j,k) * uz1(i,j,k) - enddo - - call derx (td1,ta1,x3d_op_derxp,xsize(1),xsize(2),xsize(3)) - call derx (te1,tb1,x3d_op_derx, xsize(1),xsize(2),xsize(3)) - call derx (tf1,tc1,x3d_op_derx, xsize(1),xsize(2),xsize(3)) - call derx (ta1,ux1,x3d_op_derx, xsize(1),xsize(2),xsize(3)) - call derx (tb1,uy1,x3d_op_derxp,xsize(1),xsize(2),xsize(3)) - call derx (tc1,uz1,x3d_op_derxp,xsize(1),xsize(2),xsize(3)) - - ! Convective terms of x-pencil are stored in tg1,th1,ti1 - do concurrent (k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) - dux1(i,j,k,1) = -half*(td1(i,j,k) + ux1(i,j,k) * ta1(i,j,k)) - duy1(i,j,k,1) = -half*(te1(i,j,k) + ux1(i,j,k) * tb1(i,j,k)) - duz1(i,j,k,1) = -half*(tf1(i,j,k) + ux1(i,j,k) * tc1(i,j,k)) - enddo - - call x3d_transpose_x_to_y(ux1,ux2) - call x3d_transpose_x_to_y(uy1,uy2) - call x3d_transpose_x_to_y(uz1,uz2) - - !WORK Y-PENCILS - - do concurrent (k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) - td2(i,j,k) = ux2(i,j,k) * uy2(i,j,k) - te2(i,j,k) = uy2(i,j,k) * uy2(i,j,k) - tf2(i,j,k) = uz2(i,j,k) * uy2(i,j,k) - enddo - - call dery (tg2,td2,x3d_op_dery ,ppy,ysize(1),ysize(2),ysize(3)) - call dery (th2,te2,x3d_op_deryp,ppy,ysize(1),ysize(2),ysize(3)) - call dery (ti2,tf2,x3d_op_dery ,ppy,ysize(1),ysize(2),ysize(3)) - call dery (td2,ux2,x3d_op_deryp,ppy,ysize(1),ysize(2),ysize(3)) - call dery (te2,uy2,x3d_op_dery ,ppy,ysize(1),ysize(2),ysize(3)) - call dery (tf2,uz2,x3d_op_deryp,ppy,ysize(1),ysize(2),ysize(3)) - - ! Convective terms of y-pencil in tg2,th2,ti2 - do concurrent (k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) - tg2(i,j,k) = -half*(tg2(i,j,k) + uy2(i,j,k) * td2(i,j,k)) - th2(i,j,k) = -half*(th2(i,j,k) + uy2(i,j,k) * te2(i,j,k)) - ti2(i,j,k) = -half*(ti2(i,j,k) + uy2(i,j,k) * tf2(i,j,k)) - enddo - - ! Add a part of the diffusive term if needed - if (istret /= 0 .and. xnu /= 0) then - do concurrent (k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) - tg2(i,j,k) = tg2(i,j,k) - pp4y(j)*td2(i,j,k) - th2(i,j,k) = th2(i,j,k) - pp4y(j)*te2(i,j,k) - ti2(i,j,k) = ti2(i,j,k) - pp4y(j)*tf2(i,j,k) - enddo - endif - - call x3d_transpose_y_to_z(ux2,ux3) - call x3d_transpose_y_to_z(uy2,uy3) - call x3d_transpose_y_to_z(uz2,uz3) - - !WORK Z-PENCILS - do concurrent (k=1:zsize(3), j=1:zsize(2), i=1:zsize(1)) - td3(i,j,k) = ux3(i,j,k) * uz3(i,j,k) - te3(i,j,k) = uy3(i,j,k) * uz3(i,j,k) - tf3(i,j,k) = uz3(i,j,k) * uz3(i,j,k) - enddo - - call derz (tg3,td3,x3d_op_derz ,zsize(1),zsize(2),zsize(3)) - call derz (th3,te3,x3d_op_derz ,zsize(1),zsize(2),zsize(3)) - call derz (ti3,tf3,x3d_op_derzp,zsize(1),zsize(2),zsize(3)) - call derz (td3,ux3,x3d_op_derzp,zsize(1),zsize(2),zsize(3)) - call derz (te3,uy3,x3d_op_derzp,zsize(1),zsize(2),zsize(3)) - call derz (tf3,uz3,x3d_op_derz ,zsize(1),zsize(2),zsize(3)) - - ! Convective terms of z-pencil in ta3,tb3,tc3 - do concurrent (k=1:zsize(3), j=1:zsize(2), i=1:zsize(1)) - ta3(i,j,k) = -half*(tg3(i,j,k) + uz3(i,j,k) * td3(i,j,k)) - tb3(i,j,k) = -half*(th3(i,j,k) + uz3(i,j,k) * te3(i,j,k)) - tc3(i,j,k) = -half*(ti3(i,j,k) + uz3(i,j,k) * tf3(i,j,k)) - enddo - - ! If needed, compute and add diffusion - if (xnu /= zero) then - - ! Compute diffusion in td3, te3, tf3 - call derzz(td3,ux3,x3d_op_derzzp,zsize(1),zsize(2),zsize(3)) - call derzz(te3,uy3,x3d_op_derzzp,zsize(1),zsize(2),zsize(3)) - call derzz(tf3,uz3,x3d_op_derzz ,zsize(1),zsize(2),zsize(3)) - - ! Add convective and diffusive terms of z-pencil - do concurrent (k=1:zsize(3), j=1:zsize(2), i=1:zsize(1)) - ta3(i,j,k) = ta3(i,j,k) + xnu*td3(i,j,k) - tb3(i,j,k) = tb3(i,j,k) + xnu*te3(i,j,k) - tc3(i,j,k) = tc3(i,j,k) + xnu*tf3(i,j,k) - enddo - - endif - - ! Send z-rhs (ta3,tb3,tc3) to y-pencil (td2,te2,tf2) - call x3d_transpose_z_to_y(ta3,td2) - call x3d_transpose_z_to_y(tb3,te2) - call x3d_transpose_z_to_y(tc3,tf2) - - ! If needed, compute and add diffusion - if (xnu /= 0) then - - ! Compute diffusion in ta2, tb2 and tc2 - call deryy(ta2,ux2,x3d_op_deryyp,ysize(1),ysize(2),ysize(3)) - call deryy(tb2,uy2,x3d_op_deryy ,ysize(1),ysize(2),ysize(3)) - call deryy(tc2,uz2,x3d_op_deryyp,ysize(1),ysize(2),ysize(3)) - - ! Add convective and diffusive terms of y-pencil - if (istret /= 0) then - ! In this case, a part of the y-diffusive term was added before - do concurrent (k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) - tg2(i,j,k) = tg2(i,j,k) + xnu*ta2(i,j,k)*pp2y(j) - th2(i,j,k) = th2(i,j,k) + xnu*tb2(i,j,k)*pp2y(j) - ti2(i,j,k) = ti2(i,j,k) + xnu*tc2(i,j,k)*pp2y(j) - enddo - else - do concurrent (k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) - tg2(i,j,k) = tg2(i,j,k) + xnu*ta2(i,j,k) - th2(i,j,k) = th2(i,j,k) + xnu*tb2(i,j,k) - ti2(i,j,k) = ti2(i,j,k) + xnu*tc2(i,j,k) - enddo - endif - - endif - - ! Combine y-rhs with z-rhs - do concurrent (k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) - tg2(i,j,k) = tg2(i,j,k) + td2(i,j,k) - th2(i,j,k) = th2(i,j,k) + te2(i,j,k) - ti2(i,j,k) = ti2(i,j,k) + tf2(i,j,k) - enddo - - !WORK X-PENCILS - call x3d_transpose_y_to_x(tg2,ta1) - call x3d_transpose_y_to_x(th2,tb1) - call x3d_transpose_y_to_x(ti2,tc1) !diff+conv. terms - - ! If needed, compute and add diffusion - if (xnu /= 0) then - - ! Compute diffusion in td1, te1, tf1 - call derxx(td1,ux1,x3d_op_derxx ,xsize(1),xsize(2),xsize(3)) - call derxx(te1,uy1,x3d_op_derxxp,xsize(1),xsize(2),xsize(3)) - call derxx(tf1,uz1,x3d_op_derxxp,xsize(1),xsize(2),xsize(3)) - - ! Add convective and diffusive terms of x-pencil - do concurrent (k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) - dux1(i,j,k,1) = dux1(i,j,k,1) + xnu*td1(i,j,k) - duy1(i,j,k,1) = duy1(i,j,k,1) + xnu*te1(i,j,k) - duz1(i,j,k,1) = duz1(i,j,k,1) + xnu*tf1(i,j,k) - enddo - endif - - !FINAL SUM: y and z rhs + x rhs - do concurrent (k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) - dux1(i,j,k,1) = dux1(i,j,k,1) + ta1(i,j,k) - duy1(i,j,k,1) = duy1(i,j,k,1) + tb1(i,j,k) - duz1(i,j,k,1) = duz1(i,j,k,1) + tc1(i,j,k) - enddo - - ! Add case-specific forcing in the momentum equation - call case_forcing(dux1, duy1, duz1) - - end subroutine momentum_rhs_eq - !############################################################################ - !############################################################################ + !############################################################################ + ! SUBROUTINE: calculate_transeq_rhs + ! DESCRIPTION: Calculates the right hand sides of all transport + ! equations - momentum, scalar transport, etc. + !############################################################################ + subroutine calculate_transeq_rhs(dux1, duy1, duz1, ux1, uy1, uz1) + + use decomp_2d, only: mytype + use decomp_2d, only: xsize, zsize + use param, only: ntime + + implicit none + + ! Inputs + real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: ux1, uy1, uz1 + + ! Outputs + real(mytype), dimension(xsize(1), xsize(2), xsize(3), ntime) :: dux1, duy1, duz1 + + ! Momentum equations + call momentum_rhs_eq(dux1, duy1, duz1, ux1, uy1, uz1) + + end subroutine calculate_transeq_rhs + !############################################################################ + !############################################################################ + ! + ! subroutine: momentum_rhs_eq + ! DESCRIPTION: Calculation of convective and diffusion terms of momentum + ! equation + ! + !############################################################################ + !############################################################################ + subroutine momentum_rhs_eq(dux1, duy1, duz1, ux1, uy1, uz1) + + use param + use variables + use x3d_operator_1d + use decomp_2d, only: mytype + use x3d_transpose + use x3d_derive + use decomp_2d, only: xsize, ysize, zsize + use var, only: ta1, tb1, tc1, td1, te1, tf1, tg1, th1, ti1 + use var, only: ux2, uy2, uz2, ta2, tb2, tc2, td2, te2, tf2, tg2, th2, ti2, tj2 + use var, only: ux3, uy3, uz3, ta3, tb3, tc3, td3, te3, tf3, tg3, th3, ti3 + use case, only: case_forcing + + implicit none + + ! INPUTS + real(mytype), dimension(xsize(1), xsize(2), xsize(3)) :: ux1, uy1, uz1 + + ! OUTPUTS + real(mytype), dimension(xsize(1), xsize(2), xsize(3), ntime) :: dux1, duy1, duz1 + + integer :: i, j, k, is + + !SKEW SYMMETRIC FORM + !WORK X-PENCILS + + do concurrent(k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) + ta1(i, j, k) = ux1(i, j, k)*ux1(i, j, k) + tb1(i, j, k) = ux1(i, j, k)*uy1(i, j, k) + tc1(i, j, k) = ux1(i, j, k)*uz1(i, j, k) + end do + + call derx(td1, ta1, x3d_op_derxp, xsize(1), xsize(2), xsize(3)) + call derx(te1, tb1, x3d_op_derx, xsize(1), xsize(2), xsize(3)) + call derx(tf1, tc1, x3d_op_derx, xsize(1), xsize(2), xsize(3)) + call derx(ta1, ux1, x3d_op_derx, xsize(1), xsize(2), xsize(3)) + call derx(tb1, uy1, x3d_op_derxp, xsize(1), xsize(2), xsize(3)) + call derx(tc1, uz1, x3d_op_derxp, xsize(1), xsize(2), xsize(3)) + + ! Convective terms of x-pencil are stored in tg1,th1,ti1 + do concurrent(k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) + dux1(i, j, k, 1) = -half*(td1(i, j, k) + ux1(i, j, k)*ta1(i, j, k)) + duy1(i, j, k, 1) = -half*(te1(i, j, k) + ux1(i, j, k)*tb1(i, j, k)) + duz1(i, j, k, 1) = -half*(tf1(i, j, k) + ux1(i, j, k)*tc1(i, j, k)) + end do + + call x3d_transpose_x_to_y(ux1, ux2) + call x3d_transpose_x_to_y(uy1, uy2) + call x3d_transpose_x_to_y(uz1, uz2) + + !WORK Y-PENCILS + + do concurrent(k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) + td2(i, j, k) = ux2(i, j, k)*uy2(i, j, k) + te2(i, j, k) = uy2(i, j, k)*uy2(i, j, k) + tf2(i, j, k) = uz2(i, j, k)*uy2(i, j, k) + end do + + call dery(tg2, td2, x3d_op_dery, ppy, ysize(1), ysize(2), ysize(3)) + call dery(th2, te2, x3d_op_deryp, ppy, ysize(1), ysize(2), ysize(3)) + call dery(ti2, tf2, x3d_op_dery, ppy, ysize(1), ysize(2), ysize(3)) + call dery(td2, ux2, x3d_op_deryp, ppy, ysize(1), ysize(2), ysize(3)) + call dery(te2, uy2, x3d_op_dery, ppy, ysize(1), ysize(2), ysize(3)) + call dery(tf2, uz2, x3d_op_deryp, ppy, ysize(1), ysize(2), ysize(3)) + + ! Convective terms of y-pencil in tg2,th2,ti2 + do concurrent(k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) + tg2(i, j, k) = -half*(tg2(i, j, k) + uy2(i, j, k)*td2(i, j, k)) + th2(i, j, k) = -half*(th2(i, j, k) + uy2(i, j, k)*te2(i, j, k)) + ti2(i, j, k) = -half*(ti2(i, j, k) + uy2(i, j, k)*tf2(i, j, k)) + end do + + ! Add a part of the diffusive term if needed + if (istret /= 0 .and. xnu /= 0) then + do concurrent(k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) + tg2(i, j, k) = tg2(i, j, k) - pp4y(j)*td2(i, j, k) + th2(i, j, k) = th2(i, j, k) - pp4y(j)*te2(i, j, k) + ti2(i, j, k) = ti2(i, j, k) - pp4y(j)*tf2(i, j, k) + end do + end if + + call x3d_transpose_y_to_z(ux2, ux3) + call x3d_transpose_y_to_z(uy2, uy3) + call x3d_transpose_y_to_z(uz2, uz3) + + !WORK Z-PENCILS + do concurrent(k=1:zsize(3), j=1:zsize(2), i=1:zsize(1)) + td3(i, j, k) = ux3(i, j, k)*uz3(i, j, k) + te3(i, j, k) = uy3(i, j, k)*uz3(i, j, k) + tf3(i, j, k) = uz3(i, j, k)*uz3(i, j, k) + end do + + call derz(tg3, td3, x3d_op_derz, zsize(1), zsize(2), zsize(3)) + call derz(th3, te3, x3d_op_derz, zsize(1), zsize(2), zsize(3)) + call derz(ti3, tf3, x3d_op_derzp, zsize(1), zsize(2), zsize(3)) + call derz(td3, ux3, x3d_op_derzp, zsize(1), zsize(2), zsize(3)) + call derz(te3, uy3, x3d_op_derzp, zsize(1), zsize(2), zsize(3)) + call derz(tf3, uz3, x3d_op_derz, zsize(1), zsize(2), zsize(3)) + + ! Convective terms of z-pencil in ta3,tb3,tc3 + do concurrent(k=1:zsize(3), j=1:zsize(2), i=1:zsize(1)) + ta3(i, j, k) = -half*(tg3(i, j, k) + uz3(i, j, k)*td3(i, j, k)) + tb3(i, j, k) = -half*(th3(i, j, k) + uz3(i, j, k)*te3(i, j, k)) + tc3(i, j, k) = -half*(ti3(i, j, k) + uz3(i, j, k)*tf3(i, j, k)) + end do + + ! If needed, compute and add diffusion + if (xnu /= zero) then + + ! Compute diffusion in td3, te3, tf3 + call derzz(td3, ux3, x3d_op_derzzp, zsize(1), zsize(2), zsize(3)) + call derzz(te3, uy3, x3d_op_derzzp, zsize(1), zsize(2), zsize(3)) + call derzz(tf3, uz3, x3d_op_derzz, zsize(1), zsize(2), zsize(3)) + + ! Add convective and diffusive terms of z-pencil + do concurrent(k=1:zsize(3), j=1:zsize(2), i=1:zsize(1)) + ta3(i, j, k) = ta3(i, j, k) + xnu*td3(i, j, k) + tb3(i, j, k) = tb3(i, j, k) + xnu*te3(i, j, k) + tc3(i, j, k) = tc3(i, j, k) + xnu*tf3(i, j, k) + end do + + end if + + ! Send z-rhs (ta3,tb3,tc3) to y-pencil (td2,te2,tf2) + call x3d_transpose_z_to_y(ta3, td2) + call x3d_transpose_z_to_y(tb3, te2) + call x3d_transpose_z_to_y(tc3, tf2) + + ! If needed, compute and add diffusion + if (xnu /= 0) then + + ! Compute diffusion in ta2, tb2 and tc2 + call deryy(ta2, ux2, x3d_op_deryyp, ysize(1), ysize(2), ysize(3)) + call deryy(tb2, uy2, x3d_op_deryy, ysize(1), ysize(2), ysize(3)) + call deryy(tc2, uz2, x3d_op_deryyp, ysize(1), ysize(2), ysize(3)) + + ! Add convective and diffusive terms of y-pencil + if (istret /= 0) then + ! In this case, a part of the y-diffusive term was added before + do concurrent(k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) + tg2(i, j, k) = tg2(i, j, k) + xnu*ta2(i, j, k)*pp2y(j) + th2(i, j, k) = th2(i, j, k) + xnu*tb2(i, j, k)*pp2y(j) + ti2(i, j, k) = ti2(i, j, k) + xnu*tc2(i, j, k)*pp2y(j) + end do + else + do concurrent(k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) + tg2(i, j, k) = tg2(i, j, k) + xnu*ta2(i, j, k) + th2(i, j, k) = th2(i, j, k) + xnu*tb2(i, j, k) + ti2(i, j, k) = ti2(i, j, k) + xnu*tc2(i, j, k) + end do + end if + + end if + + ! Combine y-rhs with z-rhs + do concurrent(k=1:ysize(3), j=1:ysize(2), i=1:ysize(1)) + tg2(i, j, k) = tg2(i, j, k) + td2(i, j, k) + th2(i, j, k) = th2(i, j, k) + te2(i, j, k) + ti2(i, j, k) = ti2(i, j, k) + tf2(i, j, k) + end do + + !WORK X-PENCILS + call x3d_transpose_y_to_x(tg2, ta1) + call x3d_transpose_y_to_x(th2, tb1) + call x3d_transpose_y_to_x(ti2, tc1) !diff+conv. terms + + ! If needed, compute and add diffusion + if (xnu /= 0) then + + ! Compute diffusion in td1, te1, tf1 + call derxx(td1, ux1, x3d_op_derxx, xsize(1), xsize(2), xsize(3)) + call derxx(te1, uy1, x3d_op_derxxp, xsize(1), xsize(2), xsize(3)) + call derxx(tf1, uz1, x3d_op_derxxp, xsize(1), xsize(2), xsize(3)) + + ! Add convective and diffusive terms of x-pencil + do concurrent(k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) + dux1(i, j, k, 1) = dux1(i, j, k, 1) + xnu*td1(i, j, k) + duy1(i, j, k, 1) = duy1(i, j, k, 1) + xnu*te1(i, j, k) + duz1(i, j, k, 1) = duz1(i, j, k, 1) + xnu*tf1(i, j, k) + end do + end if + + !FINAL SUM: y and z rhs + x rhs + do concurrent(k=1:xsize(3), j=1:xsize(2), i=1:xsize(1)) + dux1(i, j, k, 1) = dux1(i, j, k, 1) + ta1(i, j, k) + duy1(i, j, k, 1) = duy1(i, j, k, 1) + tb1(i, j, k) + duz1(i, j, k, 1) = duz1(i, j, k, 1) + tc1(i, j, k) + end do + + ! Add case-specific forcing in the momentum equation + call case_forcing(dux1, duy1, duz1) + + end subroutine momentum_rhs_eq + !############################################################################ + !############################################################################ end module transeq diff --git a/src/var.f90 b/src/var.f90 index 839d501..3a01a24 100644 --- a/src/var.f90 +++ b/src/var.f90 @@ -4,331 +4,327 @@ module var - use decomp_2d, only : mytype - - implicit none - - ! define all major arrays here - real(mytype), save, allocatable, dimension(:,:,:) :: ux1, ux2, ux3, po3, dv3 - real(mytype), save, allocatable, dimension(:,:,:,:) :: pp3 - real(mytype), save, allocatable, dimension(:,:,:) :: uy1, uy2, uy3 - real(mytype), save, allocatable, dimension(:,:,:) :: uz1, uz2, uz3 - real(mytype), save, allocatable, dimension(:,:,:) :: divu3 - real(mytype), save, allocatable, dimension(:,:,:) :: px1, py1, pz1 - real(mytype), save, allocatable, dimension(:,:,:,:) :: dux1,duy1,duz1 ! Output of convdiff - - - ! define all work arrays here - real(mytype), save, allocatable, dimension(:,:,:) :: ta1,tb1,tc1,td1,& - te1,tf1,tg1,th1,ti1 - real(mytype), save, allocatable, dimension(:,:,:) :: pp1,pgy1,pgz1 - real(mytype), save, allocatable, dimension(:,:,:) :: ta2,tb2,tc2,td2,& - te2,tf2,tg2,th2,ti2,tj2 - real(mytype), save, allocatable, dimension(:,:,:) :: pp2,ppi2,pgy2,pgz2,pgzi2,duxdxp2,uyp2,uzp2,upi2,duydypi2 - real(mytype), save, allocatable, dimension(:,:,:) :: ta3,tb3,tc3,td3,& - te3,tf3,tg3,th3,ti3 - real(mytype), save, allocatable, dimension(:,:,:) :: pgz3,ppi3,duxydxyp3,uzp3 - + use decomp_2d, only: mytype + + implicit none + + ! define all major arrays here + real(mytype), save, allocatable, dimension(:, :, :) :: ux1, ux2, ux3, po3, dv3 + real(mytype), save, allocatable, dimension(:, :, :, :) :: pp3 + real(mytype), save, allocatable, dimension(:, :, :) :: uy1, uy2, uy3 + real(mytype), save, allocatable, dimension(:, :, :) :: uz1, uz2, uz3 + real(mytype), save, allocatable, dimension(:, :, :) :: divu3 + real(mytype), save, allocatable, dimension(:, :, :) :: px1, py1, pz1 + real(mytype), save, allocatable, dimension(:, :, :, :) :: dux1, duy1, duz1 ! Output of convdiff + + ! define all work arrays here + real(mytype), save, allocatable, dimension(:, :, :) :: ta1, tb1, tc1, td1, & + te1, tf1, tg1, th1, ti1 + real(mytype), save, allocatable, dimension(:, :, :) :: pp1, pgy1, pgz1 + real(mytype), save, allocatable, dimension(:, :, :) :: ta2, tb2, tc2, td2, & + te2, tf2, tg2, th2, ti2, tj2 + real(mytype), save, allocatable, dimension(:, :, :) :: pp2, ppi2, pgy2, pgz2, pgzi2, duxdxp2, uyp2, uzp2, upi2, duydypi2 + real(mytype), save, allocatable, dimension(:, :, :) :: ta3, tb3, tc3, td3, & + te3, tf3, tg3, th3, ti3 + real(mytype), save, allocatable, dimension(:, :, :) :: pgz3, ppi3, duxydxyp3, uzp3 contains + ! + ! Allocate memory and initialize arrays + ! + subroutine var_init() - ! - ! Allocate memory and initialize arrays - ! - subroutine var_init() - - use variables - use param - use decomp_2d, only : DECOMP_INFO - use decomp_2d , only : alloc_x, alloc_y, alloc_z - use decomp_2d , only : xsize, ysize, zsize, ph1, ph3 - use decomp_2d , only : nrank + use variables + use param + use decomp_2d, only: DECOMP_INFO + use decomp_2d, only: alloc_x, alloc_y, alloc_z + use decomp_2d, only: xsize, ysize, zsize, ph1, ph3 + use decomp_2d, only: nrank - implicit none + implicit none - integer :: i, j , k + integer :: i, j, k #ifdef DEBUG - if (nrank == 0) write(*,*) '# var_init start' + if (nrank == 0) write (*, *) '# var_init start' #endif - if (nrank == 0) write(*,*) '# Initializing variables...' - - !xsize(i), ysize(i), zsize(i), i=1,2,3 - sizes of the sub-domains held by the current process. The first letter refers to the pencil orientation and the three 1D array elements contain the sub-domain sizes in X, Y and Z directions, respectively. In a 2D pencil decomposition, there is always one dimension which completely resides in local memory. So by definition xsize(1)==nx_global, ysize(2)==ny_global and zsize(3)==nz_global. - - !xstart(i), ystart(i), zstart(i), xend(i), yend(i), zend(i), i=1,2,3 - the starting and ending indices for each sub-domain, as in the global coordinate system. Obviously, it can be seen that xsize(i)=xend(i)-xstart(i)+1. It may be convenient for certain applications to use global coordinate (for example when extracting a 2D plane from a 3D domain, it is easier to know which process owns the plane if global index is used). - - - !X PENCILS - call alloc_x(ux1) - ux1 = zero - allocate(uy1, uz1, px1, py1, pz1, source=ux1) - - call alloc_x(ta1) - ta1 = zero - allocate(tb1, tc1, td1, te1, tf1, tg1, th1, ti1, source=ta1) - - allocate(pp1(nxm,xsize(2),xsize(3))) - pp1 = zero - allocate(pgy1, source=pp1) - allocate(pgz1, source=pp1) - - !pre_correc 2d array - allocate(dpdyx1(xsize(2),xsize(3))) - dpdyx1=zero - allocate(dpdyxn, dpdzx1, dpdzxn, source=dpdyx1) - allocate(dpdxy1(xsize(1),xsize(3))) - dpdxy1=zero - allocate(dpdxyn, dpdzy1, dpdzyn, source=dpdxy1) - allocate(dpdxz1(xsize(1),xsize(2))) - dpdxz1=zero - allocate(dpdxzn, dpdyz1, dpdyzn, source=dpdxz1) - - !Y PENCILS - call alloc_y(ux2) - ux2=zero - allocate(uy2, uz2, ta2, tb2, tc2, td2, te2, tf2, tg2, th2, ti2, tj2, source=ux2) - allocate(pp2(ph3%yst(1):ph3%yen(1),nym,ysize(3))) - pp2=zero - allocate(pgz2, source=pp2) - allocate(ppi2(ph3%yst(1):ph3%yen(1),ysize(2),ysize(3))) - ppi2=zero - allocate(pgy2, pgzi2, source=ppi2) - allocate(duxdxp2(ph1%yst(1):ph1%yen(1),ysize(2),ysize(3))) - duxdxp2=zero - allocate(uyp2, uzp2, source=duxdxp2) - allocate(upi2(ph1%yst(1):ph1%yen(1),nym,ysize(3))) - upi2=zero - allocate(duydypi2, source=upi2) - - !Z PENCILS - call alloc_z(ux3) - ux3=zero - allocate(uy3, uz3, ta3, tb3, tc3, td3, te3, tf3, tg3, th3, ti3, source=ux3) - allocate(ppi3(ph3%zst(1):ph3%zen(1),ph3%zst(2):ph3%zen(2),zsize(3))) - ppi3=zero - allocate(pgz3, source=ppi3) - - allocate(duxydxyp3(ph1%zst(1):ph1%zen(1),ph1%zst(2):ph1%zen(2),zsize(3))) - duxydxyp3=zero - allocate(uzp3, source=duxydxyp3) - - allocate(pp3(ph1%zst(1):ph1%zen(1), ph1%zst(2):ph1%zen(2), nzm, npress)) - pp3=zero - - call alloc_z(dv3, ph1, .true.) - dv3=zero - allocate(po3, source=dv3) - - !module waves - allocate(zkz(nz/2+1)) - zkz=zero - allocate(zk2, ezs, source=zkz) - - allocate(yky(ny)) - yky=zero - allocate(yk2, eys, source=yky) - - allocate(xkx(nx)) - xkx=zero - allocate(xk2, exs, source=xkx) - - !module mesh - allocate(ppy(ny)) - ppy=zero - allocate(pp2y, pp4y, ppyi, pp2yi, pp4yi, source=ppy) - - allocate(xp(nx)) - xp=zero - allocate(xpi, source=xp) - - allocate(yp, ypi, del, source=ppy) - - allocate(zp(nz)) - zp=zero - allocate(zpi, source=zp) - - allocate(yeta(ny)) - yeta=zero - allocate(yetai, source=yeta) - - ! x-position - do i=1,nx - xp(i)=real(i-1,mytype)*dx - xpi(i)=(real(i,mytype)-half)*dx - enddo - ! y-position - if (istret.eq.0) then - do j=1,ny - yp(j)=real(j-1,mytype)*dy - ypi(j)=(real(j,mytype)-half)*dy - enddo - endif - ! z-position - do k=1,nz - zp(k)=real(k-1,mytype)*dz - zpi(k)=(real(k,mytype)-half)*dz - enddo - ! - adt=zero - bdt=zero - cdt=zero - gdt=zero - - if (itimescheme.eq.1) then ! Euler - - iadvance_time=1 - - adt(1)=one*dt - bdt(1)=zero - gdt(1)=adt(1)+bdt(1) - gdt(3)=gdt(1) - - ntime = 1 - endif - allocate(dux1(xsize(1),xsize(2),xsize(3),ntime)) - dux1=zero - allocate(duy1, duz1, source=dux1) - - call alloc_z(divu3, opt_global=.true.) !global indices - divu3=zero + if (nrank == 0) write (*, *) '# Initializing variables...' + + !xsize(i), ysize(i), zsize(i), i=1,2,3 - sizes of the sub-domains held by the current process. The first letter refers to the pencil orientation and the three 1D array elements contain the sub-domain sizes in X, Y and Z directions, respectively. In a 2D pencil decomposition, there is always one dimension which completely resides in local memory. So by definition xsize(1)==nx_global, ysize(2)==ny_global and zsize(3)==nz_global. + + !xstart(i), ystart(i), zstart(i), xend(i), yend(i), zend(i), i=1,2,3 - the starting and ending indices for each sub-domain, as in the global coordinate system. Obviously, it can be seen that xsize(i)=xend(i)-xstart(i)+1. It may be convenient for certain applications to use global coordinate (for example when extracting a 2D plane from a 3D domain, it is easier to know which process owns the plane if global index is used). + + !X PENCILS + call alloc_x(ux1) + ux1 = zero + allocate (uy1, uz1, px1, py1, pz1, source=ux1) + + call alloc_x(ta1) + ta1 = zero + allocate (tb1, tc1, td1, te1, tf1, tg1, th1, ti1, source=ta1) + + allocate (pp1(nxm, xsize(2), xsize(3))) + pp1 = zero + allocate (pgy1, source=pp1) + allocate (pgz1, source=pp1) + + !pre_correc 2d array + allocate (dpdyx1(xsize(2), xsize(3))) + dpdyx1 = zero + allocate (dpdyxn, dpdzx1, dpdzxn, source=dpdyx1) + allocate (dpdxy1(xsize(1), xsize(3))) + dpdxy1 = zero + allocate (dpdxyn, dpdzy1, dpdzyn, source=dpdxy1) + allocate (dpdxz1(xsize(1), xsize(2))) + dpdxz1 = zero + allocate (dpdxzn, dpdyz1, dpdyzn, source=dpdxz1) + + !Y PENCILS + call alloc_y(ux2) + ux2 = zero + allocate (uy2, uz2, ta2, tb2, tc2, td2, te2, tf2, tg2, th2, ti2, tj2, source=ux2) + allocate (pp2(ph3%yst(1):ph3%yen(1), nym, ysize(3))) + pp2 = zero + allocate (pgz2, source=pp2) + allocate (ppi2(ph3%yst(1):ph3%yen(1), ysize(2), ysize(3))) + ppi2 = zero + allocate (pgy2, pgzi2, source=ppi2) + allocate (duxdxp2(ph1%yst(1):ph1%yen(1), ysize(2), ysize(3))) + duxdxp2 = zero + allocate (uyp2, uzp2, source=duxdxp2) + allocate (upi2(ph1%yst(1):ph1%yen(1), nym, ysize(3))) + upi2 = zero + allocate (duydypi2, source=upi2) + + !Z PENCILS + call alloc_z(ux3) + ux3 = zero + allocate (uy3, uz3, ta3, tb3, tc3, td3, te3, tf3, tg3, th3, ti3, source=ux3) + allocate (ppi3(ph3%zst(1):ph3%zen(1), ph3%zst(2):ph3%zen(2), zsize(3))) + ppi3 = zero + allocate (pgz3, source=ppi3) + + allocate (duxydxyp3(ph1%zst(1):ph1%zen(1), ph1%zst(2):ph1%zen(2), zsize(3))) + duxydxyp3 = zero + allocate (uzp3, source=duxydxyp3) + + allocate (pp3(ph1%zst(1):ph1%zen(1), ph1%zst(2):ph1%zen(2), nzm, npress)) + pp3 = zero + + call alloc_z(dv3, ph1, .true.) + dv3 = zero + allocate (po3, source=dv3) + + !module waves + allocate (zkz(nz/2 + 1)) + zkz = zero + allocate (zk2, ezs, source=zkz) + + allocate (yky(ny)) + yky = zero + allocate (yk2, eys, source=yky) + + allocate (xkx(nx)) + xkx = zero + allocate (xk2, exs, source=xkx) + + !module mesh + allocate (ppy(ny)) + ppy = zero + allocate (pp2y, pp4y, ppyi, pp2yi, pp4yi, source=ppy) + + allocate (xp(nx)) + xp = zero + allocate (xpi, source=xp) + + allocate (yp, ypi, del, source=ppy) + + allocate (zp(nz)) + zp = zero + allocate (zpi, source=zp) + + allocate (yeta(ny)) + yeta = zero + allocate (yetai, source=yeta) + + ! x-position + do i = 1, nx + xp(i) = real(i - 1, mytype)*dx + xpi(i) = (real(i, mytype) - half)*dx + end do + ! y-position + if (istret == 0) then + do j = 1, ny + yp(j) = real(j - 1, mytype)*dy + ypi(j) = (real(j, mytype) - half)*dy + end do + end if + ! z-position + do k = 1, nz + zp(k) = real(k - 1, mytype)*dz + zpi(k) = (real(k, mytype) - half)*dz + end do + ! + adt = zero + bdt = zero + cdt = zero + gdt = zero + + if (itimescheme == 1) then ! Euler + + iadvance_time = 1 + + adt(1) = one*dt + bdt(1) = zero + gdt(1) = adt(1) + bdt(1) + gdt(3) = gdt(1) + + ntime = 1 + end if + allocate (dux1(xsize(1), xsize(2), xsize(3), ntime)) + dux1 = zero + allocate (duy1, duz1, source=dux1) + + call alloc_z(divu3, opt_global=.true.) !global indices + divu3 = zero #ifdef DEBUG - if (nrank == 0) write(*,*) '# var_init done' + if (nrank == 0) write (*, *) '# var_init done' #endif - end subroutine var_init - - ! - ! Free memory - ! - subroutine var_finalize() - - use variables - - implicit none - - !X PENCILS - deallocate(ux1) - deallocate(uy1) - deallocate(uz1) - deallocate(px1) - deallocate(py1) - deallocate(pz1) - - deallocate(ta1) - deallocate(tb1) - deallocate(tc1) - deallocate(td1) - deallocate(te1) - deallocate(tf1) - deallocate(tg1) - deallocate(th1) - deallocate(ti1) - - deallocate(pp1) - deallocate(pgy1) - deallocate(pgz1) - - !pre_correc 2d array - deallocate(dpdyx1,dpdyxn) - deallocate(dpdzx1,dpdzxn) - deallocate(dpdxy1,dpdxyn) - deallocate(dpdzy1,dpdzyn) - deallocate(dpdxz1,dpdxzn) - deallocate(dpdyz1,dpdyzn) - - !Y PENCILS - deallocate(ux2) - deallocate(uy2) - deallocate(uz2) - deallocate(ta2) - deallocate(tb2) - deallocate(tc2) - deallocate(td2) - deallocate(te2) - deallocate(tf2) - deallocate(tg2) - deallocate(th2) - deallocate(ti2) - deallocate(tj2) - deallocate(pgz2) - deallocate(pp2) - deallocate(ppi2) - deallocate(pgy2) - deallocate(pgzi2) - deallocate(duxdxp2) - deallocate(uyp2) - deallocate(uzp2) - deallocate(upi2) - deallocate(duydypi2) - - !Z PENCILS - deallocate(ux3) - deallocate(uy3) - deallocate(uz3) - deallocate(ta3) - deallocate(tb3) - deallocate(tc3) - deallocate(td3) - deallocate(te3) - deallocate(tf3) - deallocate(tg3) - deallocate(th3) - deallocate(ti3) - deallocate(pgz3) - deallocate(ppi3) - - deallocate(duxydxyp3) - deallocate(uzp3) - - deallocate(pp3) - - deallocate(dv3) - deallocate(po3) - - !module waves - deallocate(zkz) - deallocate(zk2) - deallocate(ezs) - - deallocate(yky) - deallocate(yk2) - deallocate(eys) - - deallocate(xkx) - deallocate(xk2) - deallocate(exs) - - !module mesh - deallocate(ppy) - deallocate(pp2y) - deallocate(pp4y) - - deallocate(ppyi) - deallocate(pp2yi) - deallocate(pp4yi) - - deallocate(xp) - deallocate(xpi) - - deallocate(yp) - deallocate(ypi) - deallocate(del) - - deallocate(zp) - deallocate(zpi) - - deallocate(yeta) - deallocate(yetai) - - deallocate(dux1) - deallocate(duy1) - deallocate(duz1) - - deallocate(divu3) - - end subroutine var_finalize + end subroutine var_init + + ! + ! Free memory + ! + subroutine var_finalize() + + use variables + + implicit none + + !X PENCILS + deallocate (ux1) + deallocate (uy1) + deallocate (uz1) + deallocate (px1) + deallocate (py1) + deallocate (pz1) + + deallocate (ta1) + deallocate (tb1) + deallocate (tc1) + deallocate (td1) + deallocate (te1) + deallocate (tf1) + deallocate (tg1) + deallocate (th1) + deallocate (ti1) + + deallocate (pp1) + deallocate (pgy1) + deallocate (pgz1) + + !pre_correc 2d array + deallocate (dpdyx1, dpdyxn) + deallocate (dpdzx1, dpdzxn) + deallocate (dpdxy1, dpdxyn) + deallocate (dpdzy1, dpdzyn) + deallocate (dpdxz1, dpdxzn) + deallocate (dpdyz1, dpdyzn) + + !Y PENCILS + deallocate (ux2) + deallocate (uy2) + deallocate (uz2) + deallocate (ta2) + deallocate (tb2) + deallocate (tc2) + deallocate (td2) + deallocate (te2) + deallocate (tf2) + deallocate (tg2) + deallocate (th2) + deallocate (ti2) + deallocate (tj2) + deallocate (pgz2) + deallocate (pp2) + deallocate (ppi2) + deallocate (pgy2) + deallocate (pgzi2) + deallocate (duxdxp2) + deallocate (uyp2) + deallocate (uzp2) + deallocate (upi2) + deallocate (duydypi2) + + !Z PENCILS + deallocate (ux3) + deallocate (uy3) + deallocate (uz3) + deallocate (ta3) + deallocate (tb3) + deallocate (tc3) + deallocate (td3) + deallocate (te3) + deallocate (tf3) + deallocate (tg3) + deallocate (th3) + deallocate (ti3) + deallocate (pgz3) + deallocate (ppi3) + + deallocate (duxydxyp3) + deallocate (uzp3) + + deallocate (pp3) + + deallocate (dv3) + deallocate (po3) + + !module waves + deallocate (zkz) + deallocate (zk2) + deallocate (ezs) + + deallocate (yky) + deallocate (yk2) + deallocate (eys) + + deallocate (xkx) + deallocate (xk2) + deallocate (exs) + + !module mesh + deallocate (ppy) + deallocate (pp2y) + deallocate (pp4y) + + deallocate (ppyi) + deallocate (pp2yi) + deallocate (pp4yi) + + deallocate (xp) + deallocate (xpi) + + deallocate (yp) + deallocate (ypi) + deallocate (del) + + deallocate (zp) + deallocate (zpi) + + deallocate (yeta) + deallocate (yetai) + + deallocate (dux1) + deallocate (duy1) + deallocate (duz1) + + deallocate (divu3) + + end subroutine var_finalize end module var diff --git a/src/x3d_derive.f90 b/src/x3d_derive.f90 index 808ae55..70b3928 100644 --- a/src/x3d_derive.f90 +++ b/src/x3d_derive.f90 @@ -4,1929 +4,1929 @@ module x3d_derive - use decomp_2d, only : mytype - use x3d_operator_1d, only : x3doperator1d - use param - use thomas - - implicit none - - ! Make everything public unless declared private - public - - ABSTRACT INTERFACE - SUBROUTINE DERIVATIVE_X(t,u,x3dop,nx,ny,nz) - use decomp_2d, only : mytype - use x3d_operator_1d, only : x3doperator1d - integer, intent(in) :: nx,ny,nz - real(mytype), intent(out), dimension(nx,ny,nz) :: t - real(mytype), intent(in), dimension(nx,ny,nz) :: u - type(x3doperator1d), intent(in) :: x3dop - END SUBROUTINE DERIVATIVE_X - SUBROUTINE DERIVATIVE_Y(t,u,x3dop,pp,nx,ny,nz) - use decomp_2d, only : mytype - use x3d_operator_1d, only : x3doperator1d - integer, intent(in) :: nx,ny,nz - real(mytype), intent(out), dimension(nx,ny,nz) :: t - real(mytype), intent(in), dimension(nx,ny,nz) :: u - real(mytype), intent(in), dimension(ny):: pp - type(x3doperator1d), intent(in) :: x3dop - END SUBROUTINE DERIVATIVE_Y - SUBROUTINE DERIVATIVE_YY(t,u,x3dop,nx,ny,nz) - use decomp_2d, only : mytype - use x3d_operator_1d, only : x3doperator1d - integer, intent(in) :: nx,ny,nz - real(mytype), intent(out), dimension(nx,ny,nz) :: t - real(mytype), intent(in), dimension(nx,ny,nz) :: u - type(x3doperator1d), intent(in) :: x3dop - END SUBROUTINE DERIVATIVE_YY - SUBROUTINE DERIVATIVE_Z(t,u,x3dop,nx,ny,nz) - use decomp_2d, only : mytype - use x3d_operator_1d, only : x3doperator1d - integer, intent(in) :: nx,ny,nz - real(mytype), intent(out), dimension(nx,ny,nz) :: t - real(mytype), intent(in), dimension(nx,ny,nz) :: u - type(x3doperator1d), intent(in) :: x3dop - END SUBROUTINE DERIVATIVE_Z - END INTERFACE - - PROCEDURE (DERIVATIVE_X), POINTER :: derx=>null(), derxx=>null(), & - derxS=>null(), derxxS=>null() - PROCEDURE (DERIVATIVE_Y), POINTER :: dery=>null(), deryS=>null() - PROCEDURE (DERIVATIVE_YY), POINTER :: deryy=>null(), deryyS=>null() - PROCEDURE (DERIVATIVE_Z), POINTER :: derz=>null(), derzz=>null(), & - derzS=>null(), derzzS=>null() + use decomp_2d, only: mytype + use x3d_operator_1d, only: x3doperator1d + use param + use thomas + + implicit none + + ! Make everything public unless declared private + public + + ABSTRACT INTERFACE + SUBROUTINE DERIVATIVE_X(t, u, x3dop, nx, ny, nz) + use decomp_2d, only: mytype + use x3d_operator_1d, only: x3doperator1d + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: t + real(mytype), intent(in), dimension(nx, ny, nz) :: u + type(x3doperator1d), intent(in) :: x3dop + END SUBROUTINE DERIVATIVE_X + SUBROUTINE DERIVATIVE_Y(t, u, x3dop, pp, nx, ny, nz) + use decomp_2d, only: mytype + use x3d_operator_1d, only: x3doperator1d + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: t + real(mytype), intent(in), dimension(nx, ny, nz) :: u + real(mytype), intent(in), dimension(ny):: pp + type(x3doperator1d), intent(in) :: x3dop + END SUBROUTINE DERIVATIVE_Y + SUBROUTINE DERIVATIVE_YY(t, u, x3dop, nx, ny, nz) + use decomp_2d, only: mytype + use x3d_operator_1d, only: x3doperator1d + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: t + real(mytype), intent(in), dimension(nx, ny, nz) :: u + type(x3doperator1d), intent(in) :: x3dop + END SUBROUTINE DERIVATIVE_YY + SUBROUTINE DERIVATIVE_Z(t, u, x3dop, nx, ny, nz) + use decomp_2d, only: mytype + use x3d_operator_1d, only: x3doperator1d + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: t + real(mytype), intent(in), dimension(nx, ny, nz) :: u + type(x3doperator1d), intent(in) :: x3dop + END SUBROUTINE DERIVATIVE_Z + END INTERFACE + + PROCEDURE(DERIVATIVE_X), POINTER :: derx => null(), derxx => null(), & + derxS => null(), derxxS => null() + PROCEDURE(DERIVATIVE_Y), POINTER :: dery => null(), deryS => null() + PROCEDURE(DERIVATIVE_YY), POINTER :: deryy => null(), deryyS => null() + PROCEDURE(DERIVATIVE_Z), POINTER :: derz => null(), derzz => null(), & + derzS => null(), derzzS => null() contains - ! - ! Associate pointers with subroutines - ! - subroutine x3d_derive_init() - - implicit none - - ! Velocity - ! First derivative - if (nclx1.eq.0.and.nclxn.eq.0) derx => derx_00 - if (nclx1.eq.1.and.nclxn.eq.1) derx => derx_11 - if (nclx1.eq.1.and.nclxn.eq.2) derx => derx_12 - if (nclx1.eq.2.and.nclxn.eq.1) derx => derx_21 - if (nclx1.eq.2.and.nclxn.eq.2) derx => derx_22 - ! - if (ncly1.eq.0.and.nclyn.eq.0) dery => dery_00 - if (ncly1.eq.1.and.nclyn.eq.1) dery => dery_11 - if (ncly1.eq.1.and.nclyn.eq.2) dery => dery_12 - if (ncly1.eq.2.and.nclyn.eq.1) dery => dery_21 - if (ncly1.eq.2.and.nclyn.eq.2) dery => dery_22 - ! - if (nclz1.eq.0.and.nclzn.eq.0) derz => derz_00 - if (nclz1.eq.1.and.nclzn.eq.1) derz => derz_11 - if (nclz1.eq.1.and.nclzn.eq.2) derz => derz_12 - if (nclz1.eq.2.and.nclzn.eq.1) derz => derz_21 - if (nclz1.eq.2.and.nclzn.eq.2) derz => derz_22 - ! Second derivative - if (nclx1.eq.0.and.nclxn.eq.0) derxx => derxx_00 - if (nclx1.eq.1.and.nclxn.eq.1) derxx => derxx_11 - if (nclx1.eq.1.and.nclxn.eq.2) derxx => derxx_12 - if (nclx1.eq.2.and.nclxn.eq.1) derxx => derxx_21 - if (nclx1.eq.2.and.nclxn.eq.2) derxx => derxx_22 - ! - if (ncly1.eq.0.and.nclyn.eq.0) deryy => deryy_00 - if (ncly1.eq.1.and.nclyn.eq.1) deryy => deryy_11 - if (ncly1.eq.1.and.nclyn.eq.2) deryy => deryy_12 - if (ncly1.eq.2.and.nclyn.eq.1) deryy => deryy_21 - if (ncly1.eq.2.and.nclyn.eq.2) deryy => deryy_22 - ! - if (nclz1.eq.0.and.nclzn.eq.0) derzz => derzz_00 - if (nclz1.eq.1.and.nclzn.eq.1) derzz => derzz_11 - if (nclz1.eq.1.and.nclzn.eq.2) derzz => derzz_12 - if (nclz1.eq.2.and.nclzn.eq.1) derzz => derzz_21 - if (nclz1.eq.2.and.nclzn.eq.2) derzz => derzz_22 - - ! Scalars - if (iscalar.ne.0) then + ! + ! Associate pointers with subroutines + ! + subroutine x3d_derive_init() + + implicit none + + ! Velocity ! First derivative - if (nclxS1.eq.0.and.nclxSn.eq.0) derxS => derx_00 - if (nclxS1.eq.1.and.nclxSn.eq.1) derxS => derx_11 - if (nclxS1.eq.1.and.nclxSn.eq.2) derxS => derx_12 - if (nclxS1.eq.2.and.nclxSn.eq.1) derxS => derx_21 - if (nclxS1.eq.2.and.nclxSn.eq.2) derxS => derx_22 + if (nclx1 == 0 .and. nclxn == 0) derx => derx_00 + if (nclx1 == 1 .and. nclxn == 1) derx => derx_11 + if (nclx1 == 1 .and. nclxn == 2) derx => derx_12 + if (nclx1 == 2 .and. nclxn == 1) derx => derx_21 + if (nclx1 == 2 .and. nclxn == 2) derx => derx_22 ! - if (nclyS1.eq.0.and.nclySn.eq.0) deryS => dery_00 - if (nclyS1.eq.1.and.nclySn.eq.1) deryS => dery_11 - if (nclyS1.eq.1.and.nclySn.eq.2) deryS => dery_12 - if (nclyS1.eq.2.and.nclySn.eq.1) deryS => dery_21 - if (nclyS1.eq.2.and.nclySn.eq.2) deryS => dery_22 + if (ncly1 == 0 .and. nclyn == 0) dery => dery_00 + if (ncly1 == 1 .and. nclyn == 1) dery => dery_11 + if (ncly1 == 1 .and. nclyn == 2) dery => dery_12 + if (ncly1 == 2 .and. nclyn == 1) dery => dery_21 + if (ncly1 == 2 .and. nclyn == 2) dery => dery_22 ! - if (nclzS1.eq.0.and.nclzSn.eq.0) derzS => derz_00 - if (nclzS1.eq.1.and.nclzSn.eq.1) derzS => derz_11 - if (nclzS1.eq.1.and.nclzSn.eq.2) derzS => derz_12 - if (nclzS1.eq.2.and.nclzSn.eq.1) derzS => derz_21 - if (nclzS1.eq.2.and.nclzSn.eq.2) derzS => derz_22 + if (nclz1 == 0 .and. nclzn == 0) derz => derz_00 + if (nclz1 == 1 .and. nclzn == 1) derz => derz_11 + if (nclz1 == 1 .and. nclzn == 2) derz => derz_12 + if (nclz1 == 2 .and. nclzn == 1) derz => derz_21 + if (nclz1 == 2 .and. nclzn == 2) derz => derz_22 ! Second derivative - if (nclxS1.eq.0.and.nclxSn.eq.0) derxxS => derxx_00 - if (nclxS1.eq.1.and.nclxSn.eq.1) derxxS => derxx_11 - if (nclxS1.eq.1.and.nclxSn.eq.2) derxxS => derxx_12 - if (nclxS1.eq.2.and.nclxSn.eq.1) derxxS => derxx_21 - if (nclxS1.eq.2.and.nclxSn.eq.2) derxxS => derxx_22 + if (nclx1 == 0 .and. nclxn == 0) derxx => derxx_00 + if (nclx1 == 1 .and. nclxn == 1) derxx => derxx_11 + if (nclx1 == 1 .and. nclxn == 2) derxx => derxx_12 + if (nclx1 == 2 .and. nclxn == 1) derxx => derxx_21 + if (nclx1 == 2 .and. nclxn == 2) derxx => derxx_22 ! - if (nclyS1.eq.0.and.nclySn.eq.0) deryyS => deryy_00 - if (nclyS1.eq.1.and.nclySn.eq.1) deryyS => deryy_11 - if (nclyS1.eq.1.and.nclySn.eq.2) deryyS => deryy_12 - if (nclyS1.eq.2.and.nclySn.eq.1) deryyS => deryy_21 - if (nclyS1.eq.2.and.nclySn.eq.2) deryyS => deryy_22 + if (ncly1 == 0 .and. nclyn == 0) deryy => deryy_00 + if (ncly1 == 1 .and. nclyn == 1) deryy => deryy_11 + if (ncly1 == 1 .and. nclyn == 2) deryy => deryy_12 + if (ncly1 == 2 .and. nclyn == 1) deryy => deryy_21 + if (ncly1 == 2 .and. nclyn == 2) deryy => deryy_22 ! - if (nclzS1.eq.0.and.nclzSn.eq.0) derzzS => derzz_00 - if (nclzS1.eq.1.and.nclzSn.eq.1) derzzS => derzz_11 - if (nclzS1.eq.1.and.nclzSn.eq.2) derzzS => derzz_12 - if (nclzS1.eq.2.and.nclzSn.eq.1) derzzS => derzz_21 - if (nclzS1.eq.2.and.nclzSn.eq.2) derzzS => derzz_22 - endif - - end subroutine x3d_derive_init - - ! - ! Associate pointers with subroutines - ! - subroutine x3d_derive_finalize() - - implicit none - - ! Velocity - ! First derivative - nullify(derx) - nullify(dery) - nullify(derz) - ! Second derivative - nullify(derxx) - nullify(deryy) - nullify(derzz) - - ! Scalars - if (iscalar.ne.0) then + if (nclz1 == 0 .and. nclzn == 0) derzz => derzz_00 + if (nclz1 == 1 .and. nclzn == 1) derzz => derzz_11 + if (nclz1 == 1 .and. nclzn == 2) derzz => derzz_12 + if (nclz1 == 2 .and. nclzn == 1) derzz => derzz_21 + if (nclz1 == 2 .and. nclzn == 2) derzz => derzz_22 + + ! Scalars + if (iscalar /= 0) then + ! First derivative + if (nclxS1 == 0 .and. nclxSn == 0) derxS => derx_00 + if (nclxS1 == 1 .and. nclxSn == 1) derxS => derx_11 + if (nclxS1 == 1 .and. nclxSn == 2) derxS => derx_12 + if (nclxS1 == 2 .and. nclxSn == 1) derxS => derx_21 + if (nclxS1 == 2 .and. nclxSn == 2) derxS => derx_22 + ! + if (nclyS1 == 0 .and. nclySn == 0) deryS => dery_00 + if (nclyS1 == 1 .and. nclySn == 1) deryS => dery_11 + if (nclyS1 == 1 .and. nclySn == 2) deryS => dery_12 + if (nclyS1 == 2 .and. nclySn == 1) deryS => dery_21 + if (nclyS1 == 2 .and. nclySn == 2) deryS => dery_22 + ! + if (nclzS1 == 0 .and. nclzSn == 0) derzS => derz_00 + if (nclzS1 == 1 .and. nclzSn == 1) derzS => derz_11 + if (nclzS1 == 1 .and. nclzSn == 2) derzS => derz_12 + if (nclzS1 == 2 .and. nclzSn == 1) derzS => derz_21 + if (nclzS1 == 2 .and. nclzSn == 2) derzS => derz_22 + ! Second derivative + if (nclxS1 == 0 .and. nclxSn == 0) derxxS => derxx_00 + if (nclxS1 == 1 .and. nclxSn == 1) derxxS => derxx_11 + if (nclxS1 == 1 .and. nclxSn == 2) derxxS => derxx_12 + if (nclxS1 == 2 .and. nclxSn == 1) derxxS => derxx_21 + if (nclxS1 == 2 .and. nclxSn == 2) derxxS => derxx_22 + ! + if (nclyS1 == 0 .and. nclySn == 0) deryyS => deryy_00 + if (nclyS1 == 1 .and. nclySn == 1) deryyS => deryy_11 + if (nclyS1 == 1 .and. nclySn == 2) deryyS => deryy_12 + if (nclyS1 == 2 .and. nclySn == 1) deryyS => deryy_21 + if (nclyS1 == 2 .and. nclySn == 2) deryyS => deryy_22 + ! + if (nclzS1 == 0 .and. nclzSn == 0) derzzS => derzz_00 + if (nclzS1 == 1 .and. nclzSn == 1) derzzS => derzz_11 + if (nclzS1 == 1 .and. nclzSn == 2) derzzS => derzz_12 + if (nclzS1 == 2 .and. nclzSn == 1) derzzS => derzz_21 + if (nclzS1 == 2 .and. nclzSn == 2) derzzS => derzz_22 + end if + + end subroutine x3d_derive_init + + ! + ! Associate pointers with subroutines + ! + subroutine x3d_derive_finalize() + + implicit none + + ! Velocity ! First derivative - nullify(derxS) - nullify(deryS) - nullify(derzS) + nullify (derx) + nullify (dery) + nullify (derz) ! Second derivative - nullify(derxxS) - nullify(deryyS) - nullify(derzzS) - endif - - end subroutine x3d_derive_finalize - -subroutine derx_00(tx,ux,x3dop,nx,ny,nz) - - use x3d_operator_x_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - do concurrent (k=1:nz, j=1:ny) - ! Compute r.h.s. - tx(1,j,k) = afix*(ux(2,j,k)-ux(nx,j,k)) & - + bfix*(ux(3,j,k)-ux(nx-1,j,k)) - tx(2,j,k) = afix*(ux(3,j,k)-ux(1,j,k)) & - + bfix*(ux(4,j,k)-ux(nx,j,k)) - do concurrent (i=3:nx-2) - tx(i,j,k) = afix*(ux(i+1,j,k)-ux(i-1,j,k)) & - + bfix*(ux(i+2,j,k)-ux(i-2,j,k)) - enddo - tx(nx-1,j,k) = afix*(ux(nx,j,k)-ux(nx-2,j,k)) & - + bfix*(ux(1,j,k)-ux(nx-3,j,k)) - tx(nx,j,k) = afix*(ux(1,j,k)-ux(nx-1,j,k)) & - + bfix*(ux(2,j,k)-ux(nx-2,j,k)) - - enddo - - ! Solve tri-diagonal system - call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - -end subroutine derx_00 + nullify (derxx) + nullify (deryy) + nullify (derzz) + + ! Scalars + if (iscalar /= 0) then + ! First derivative + nullify (derxS) + nullify (deryS) + nullify (derzS) + ! Second derivative + nullify (derxxS) + nullify (deryyS) + nullify (derzzS) + end if + + end subroutine x3d_derive_finalize + + subroutine derx_00(tx, ux, x3dop, nx, ny, nz) + + use x3d_operator_x_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + do concurrent(k=1:nz, j=1:ny) + ! Compute r.h.s. + tx(1, j, k) = afix*(ux(2, j, k) - ux(nx, j, k)) & + + bfix*(ux(3, j, k) - ux(nx - 1, j, k)) + tx(2, j, k) = afix*(ux(3, j, k) - ux(1, j, k)) & + + bfix*(ux(4, j, k) - ux(nx, j, k)) + do concurrent(i=3:nx - 2) + tx(i, j, k) = afix*(ux(i + 1, j, k) - ux(i - 1, j, k)) & + + bfix*(ux(i + 2, j, k) - ux(i - 2, j, k)) + end do + tx(nx - 1, j, k) = afix*(ux(nx, j, k) - ux(nx - 2, j, k)) & + + bfix*(ux(1, j, k) - ux(nx - 3, j, k)) + tx(nx, j, k) = afix*(ux(1, j, k) - ux(nx - 1, j, k)) & + + bfix*(ux(2, j, k) - ux(nx - 2, j, k)) + + end do + + ! Solve tri-diagonal system + call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + end subroutine derx_00 !******************************************************************** ! -subroutine derx_ij(tx,ux,ff,fs,fw,nx,ny,nz,npaire,ncl1,ncln) - - use x3d_operator_x_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - real(mytype), intent(in), dimension(nx):: ff, fs, fw - - ! Local variables - integer :: i, j, k - - do concurrent (k=1:nz, j=1:ny) - ! Compute r.h.s. - if (ncl1==1) then - if (npaire==1) then - tx(1,j,k) = zero - tx(2,j,k) = afix*(ux(3,j,k)-ux(1,j,k)) & - + bfix*(ux(4,j,k)-ux(2,j,k)) - else - tx(1,j,k) = afix*(ux(2,j,k)+ux(2,j,k)) & - + bfix*(ux(3,j,k)+ux(3,j,k)) - tx(2,j,k) = afix*(ux(3,j,k)-ux(1,j,k)) & - + bfix*(ux(4,j,k)+ux(2,j,k)) - endif - else - tx(1,j,k) = af1x*ux(1,j,k) + bf1x*ux(2,j,k) + cf1x*ux(3,j,k) - tx(2,j,k) = af2x*(ux(3,j,k)-ux(1,j,k)) - endif - do concurrent (i=3:nx-2) - tx(i,j,k) = afix*(ux(i+1,j,k)-ux(i-1,j,k)) & - + bfix*(ux(i+2,j,k)-ux(i-2,j,k)) - enddo - ! nx-1 <= i <= nx - if (ncln==1) then - if (npaire==1) then - tx(nx-1,j,k) = afix*(ux(nx,j,k)-ux(nx-2,j,k)) & - + bfix*(ux(nx-1,j,k)-ux(nx-3,j,k)) - tx(nx,j,k) = zero - else - tx(nx-1,j,k) = afix*(ux(nx,j,k)-ux(nx-2,j,k)) & - + bfix*((-ux(nx-1,j,k))-ux(nx-3,j,k)) - tx(nx,j,k) = afix*((-ux(nx-1,j,k))-ux(nx-1,j,k)) & - + bfix*((-ux(nx-2,j,k))-ux(nx-2,j,k)) - endif - else - tx(nx-1,j,k) = afmx*(ux(nx,j,k)-ux(nx-2,j,k)) - tx(nx,j,k) = - afnx*ux(nx,j,k) - bfnx*ux(nx-1,j,k) - cfnx*ux(nx-2,j,k) - endif - enddo - - ! Solve tri-diagonal system - call xthomas(tx, ff, fs, fw, nx, ny, nz) - -end subroutine derx_ij + subroutine derx_ij(tx, ux, ff, fs, fw, nx, ny, nz, npaire, ncl1, ncln) + + use x3d_operator_x_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + real(mytype), intent(in), dimension(nx):: ff, fs, fw + + ! Local variables + integer :: i, j, k + + do concurrent(k=1:nz, j=1:ny) + ! Compute r.h.s. + if (ncl1 == 1) then + if (npaire == 1) then + tx(1, j, k) = zero + tx(2, j, k) = afix*(ux(3, j, k) - ux(1, j, k)) & + + bfix*(ux(4, j, k) - ux(2, j, k)) + else + tx(1, j, k) = afix*(ux(2, j, k) + ux(2, j, k)) & + + bfix*(ux(3, j, k) + ux(3, j, k)) + tx(2, j, k) = afix*(ux(3, j, k) - ux(1, j, k)) & + + bfix*(ux(4, j, k) + ux(2, j, k)) + end if + else + tx(1, j, k) = af1x*ux(1, j, k) + bf1x*ux(2, j, k) + cf1x*ux(3, j, k) + tx(2, j, k) = af2x*(ux(3, j, k) - ux(1, j, k)) + end if + do concurrent(i=3:nx - 2) + tx(i, j, k) = afix*(ux(i + 1, j, k) - ux(i - 1, j, k)) & + + bfix*(ux(i + 2, j, k) - ux(i - 2, j, k)) + end do + ! nx-1 <= i <= nx + if (ncln == 1) then + if (npaire == 1) then + tx(nx - 1, j, k) = afix*(ux(nx, j, k) - ux(nx - 2, j, k)) & + + bfix*(ux(nx - 1, j, k) - ux(nx - 3, j, k)) + tx(nx, j, k) = zero + else + tx(nx - 1, j, k) = afix*(ux(nx, j, k) - ux(nx - 2, j, k)) & + + bfix*((-ux(nx - 1, j, k)) - ux(nx - 3, j, k)) + tx(nx, j, k) = afix*((-ux(nx - 1, j, k)) - ux(nx - 1, j, k)) & + + bfix*((-ux(nx - 2, j, k)) - ux(nx - 2, j, k)) + end if + else + tx(nx - 1, j, k) = afmx*(ux(nx, j, k) - ux(nx - 2, j, k)) + tx(nx, j, k) = -afnx*ux(nx, j, k) - bfnx*ux(nx - 1, j, k) - cfnx*ux(nx - 2, j, k) + end if + end do + + ! Solve tri-diagonal system + call xthomas(tx, ff, fs, fw, nx, ny, nz) + + end subroutine derx_ij !******************************************************************** ! -subroutine derx_11(tx,ux,x3dop,nx,ny,nz) + subroutine derx_11(tx, ux, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop - call derx_ij(tx,ux,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,1,1) + call derx_ij(tx, ux, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 1, 1) -end subroutine derx_11 + end subroutine derx_11 !******************************************************************** ! -subroutine derx_12(tx,ux,x3dop,nx,ny,nz) + subroutine derx_12(tx, ux, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop - call derx_ij(tx,ux,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,1,2) + call derx_ij(tx, ux, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 1, 2) -end subroutine derx_12 + end subroutine derx_12 !******************************************************************** ! -subroutine derx_21(tx,ux,x3dop,nx,ny,nz) + subroutine derx_21(tx, ux, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop - call derx_ij(tx,ux,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,2,1) + call derx_ij(tx, ux, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 2, 1) -end subroutine derx_21 + end subroutine derx_21 !******************************************************************** ! -subroutine derx_22(tx,ux,x3dop,nx,ny,nz) + subroutine derx_22(tx, ux, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop - call derx_ij(tx,ux,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,2,2) + call derx_ij(tx, ux, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 2, 2) -end subroutine derx_22 + end subroutine derx_22 !******************************************************************** ! -subroutine dery_00(ty,uy,x3dop,ppy,nx,ny,nz) - ! - !******************************************************************** - - use x3d_operator_y_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - real(mytype), intent(in), dimension(ny) :: ppy - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - ! Compute r.h.s. - do concurrent (k=1:nz) - do concurrent (i=1:nx) - ty(i,1,k) = afjy*(uy(i,2,k)-uy(i,ny,k)) & - + bfjy*(uy(i,3,k)-uy(i,ny-1,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = afjy*(uy(i,3,k)-uy(i,1,k)) & - + bfjy*(uy(i,4,k)-uy(i,ny,k)) - enddo - do concurrent (j=3:ny-2, i=1:nx) - ty(i,j,k) = afjy*(uy(i,j+1,k)-uy(i,j-1,k)) & - + bfjy*(uy(i,j+2,k)-uy(i,j-2,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = afjy*(uy(i,ny,k)-uy(i,ny-2,k)) & - + bfjy*(uy(i,1,k)-uy(i,ny-3,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny,k) = afjy*(uy(i,1,k)-uy(i,ny-1,k)) & - + bfjy*(uy(i,2,k)-uy(i,ny-2,k)) - enddo - enddo - - ! Solve tri-diagonal system - call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - ! Apply stretching if needed - if (istret /= 0) then - do concurrent (k=1:nz, j=1:ny, i=1:nx) - ty(i,j,k) = ty(i,j,k) * ppy(j) - enddo - endif - -end subroutine dery_00 + subroutine dery_00(ty, uy, x3dop, ppy, nx, ny, nz) + ! + !******************************************************************** + + use x3d_operator_y_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + real(mytype), intent(in), dimension(ny) :: ppy + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + ! Compute r.h.s. + do concurrent(k=1:nz) + do concurrent(i=1:nx) + ty(i, 1, k) = afjy*(uy(i, 2, k) - uy(i, ny, k)) & + + bfjy*(uy(i, 3, k) - uy(i, ny - 1, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = afjy*(uy(i, 3, k) - uy(i, 1, k)) & + + bfjy*(uy(i, 4, k) - uy(i, ny, k)) + end do + do concurrent(j=3:ny - 2, i=1:nx) + ty(i, j, k) = afjy*(uy(i, j + 1, k) - uy(i, j - 1, k)) & + + bfjy*(uy(i, j + 2, k) - uy(i, j - 2, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = afjy*(uy(i, ny, k) - uy(i, ny - 2, k)) & + + bfjy*(uy(i, 1, k) - uy(i, ny - 3, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = afjy*(uy(i, 1, k) - uy(i, ny - 1, k)) & + + bfjy*(uy(i, 2, k) - uy(i, ny - 2, k)) + end do + end do + + ! Solve tri-diagonal system + call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + ! Apply stretching if needed + if (istret /= 0) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + ty(i, j, k) = ty(i, j, k)*ppy(j) + end do + end if + + end subroutine dery_00 !******************************************************************** ! -subroutine dery_ij(ty,uy,ff,fs,fw,ppy,nx,ny,nz,npaire,ncl1,ncln) - - use x3d_operator_y_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - real(mytype), intent(in), dimension(ny) :: ff,fs,fw,ppy - - ! Local variables - integer :: i, j, k - - do concurrent (k=1:nz) - - ! Compute r.h.s. - if (ncl1==1) then - if (npaire==1) then - do concurrent (i=1:nx) - ty(i,1,k) = zero - enddo - do concurrent (i=1:nx) - ty(i,2,k) = afjy*(uy(i,3,k)-uy(i,1,k)) & - + bfjy*(uy(i,4,k)-uy(i,2,k)) - enddo - else - do concurrent (i=1:nx) - ty(i,1,k) = afjy*(uy(i,2,k)+uy(i,2,k)) & - + bfjy*(uy(i,3,k)+uy(i,3,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = afjy*(uy(i,3,k)-uy(i,1,k)) & - + bfjy*(uy(i,4,k)+uy(i,2,k)) - enddo - endif - else - do concurrent (i=1:nx) - ty(i,1,k) = af1y*uy(i,1,k)+bf1y*uy(i,2,k)+cf1y*uy(i,3,k) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = af2y*(uy(i,3,k)-uy(i,1,k)) - enddo - endif - do concurrent (j=3:ny-2, i=1:nx) - ty(i,j,k) = afjy*(uy(i,j+1,k)-uy(i,j-1,k)) & - + bfjy*(uy(i,j+2,k)-uy(i,j-2,k)) - enddo - if (ncln==1) then - if (npaire==1) then - do concurrent (i=1:nx) - ty(i,ny-1,k) = afjy*(uy(i,ny,k)-uy(i,ny-2,k)) & - + bfjy*(uy(i,ny-1,k)-uy(i,ny-3,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny,k) = zero - enddo - else - do concurrent (i=1:nx) - ty(i,ny-1,k) = afjy*(uy(i,ny,k)-uy(i,ny-2,k)) & - + bfjy*((-uy(i,ny-1,k))-uy(i,ny-3,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny,k) = afjy*((-uy(i,ny-1,k))-uy(i,ny-1,k)) & - + bfjy*((-uy(i,ny-2,k))-uy(i,ny-2,k)) - enddo - endif - else - do concurrent (i=1:nx) - ty(i,ny-1,k) = afmy*(uy(i,ny,k)-uy(i,ny-2,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny,k) = -afny*uy(i,ny,k)-bfny*uy(i,ny-1,k)-cfny*uy(i,ny-2,k) - enddo - endif - enddo - - ! Solve tri-diagonal system - call ythomas(ty, ff, fs, fw, nx, ny, nz) - - ! Apply stretching if needed - if (istret /= 0) then - do concurrent (k=1:nz, j=1:ny, i=1:nx) - ty(i,j,k) = ty(i,j,k) * ppy(j) - enddo - endif - -end subroutine dery_ij + subroutine dery_ij(ty, uy, ff, fs, fw, ppy, nx, ny, nz, npaire, ncl1, ncln) + + use x3d_operator_y_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + real(mytype), intent(in), dimension(ny) :: ff, fs, fw, ppy + + ! Local variables + integer :: i, j, k + + do concurrent(k=1:nz) + + ! Compute r.h.s. + if (ncl1 == 1) then + if (npaire == 1) then + do concurrent(i=1:nx) + ty(i, 1, k) = zero + end do + do concurrent(i=1:nx) + ty(i, 2, k) = afjy*(uy(i, 3, k) - uy(i, 1, k)) & + + bfjy*(uy(i, 4, k) - uy(i, 2, k)) + end do + else + do concurrent(i=1:nx) + ty(i, 1, k) = afjy*(uy(i, 2, k) + uy(i, 2, k)) & + + bfjy*(uy(i, 3, k) + uy(i, 3, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = afjy*(uy(i, 3, k) - uy(i, 1, k)) & + + bfjy*(uy(i, 4, k) + uy(i, 2, k)) + end do + end if + else + do concurrent(i=1:nx) + ty(i, 1, k) = af1y*uy(i, 1, k) + bf1y*uy(i, 2, k) + cf1y*uy(i, 3, k) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = af2y*(uy(i, 3, k) - uy(i, 1, k)) + end do + end if + do concurrent(j=3:ny - 2, i=1:nx) + ty(i, j, k) = afjy*(uy(i, j + 1, k) - uy(i, j - 1, k)) & + + bfjy*(uy(i, j + 2, k) - uy(i, j - 2, k)) + end do + if (ncln == 1) then + if (npaire == 1) then + do concurrent(i=1:nx) + ty(i, ny - 1, k) = afjy*(uy(i, ny, k) - uy(i, ny - 2, k)) & + + bfjy*(uy(i, ny - 1, k) - uy(i, ny - 3, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = zero + end do + else + do concurrent(i=1:nx) + ty(i, ny - 1, k) = afjy*(uy(i, ny, k) - uy(i, ny - 2, k)) & + + bfjy*((-uy(i, ny - 1, k)) - uy(i, ny - 3, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = afjy*((-uy(i, ny - 1, k)) - uy(i, ny - 1, k)) & + + bfjy*((-uy(i, ny - 2, k)) - uy(i, ny - 2, k)) + end do + end if + else + do concurrent(i=1:nx) + ty(i, ny - 1, k) = afmy*(uy(i, ny, k) - uy(i, ny - 2, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = -afny*uy(i, ny, k) - bfny*uy(i, ny - 1, k) - cfny*uy(i, ny - 2, k) + end do + end if + end do + + ! Solve tri-diagonal system + call ythomas(ty, ff, fs, fw, nx, ny, nz) + + ! Apply stretching if needed + if (istret /= 0) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + ty(i, j, k) = ty(i, j, k)*ppy(j) + end do + end if + + end subroutine dery_ij !******************************************************************** ! -subroutine dery_11(ty,uy,x3dop,ppy,nx,ny,nz) + subroutine dery_11(ty, uy, x3dop, ppy, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - real(mytype), intent(in), dimension(ny) :: ppy - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + real(mytype), intent(in), dimension(ny) :: ppy + type(x3doperator1d), intent(in) :: x3dop - call dery_ij(ty,uy,x3dop%f,x3dop%s,x3dop%w,ppy,nx,ny,nz,x3dop%npaire,1,1) + call dery_ij(ty, uy, x3dop%f, x3dop%s, x3dop%w, ppy, nx, ny, nz, x3dop%npaire, 1, 1) -end subroutine dery_11 + end subroutine dery_11 !******************************************************************** ! -subroutine dery_12(ty,uy,x3dop,ppy,nx,ny,nz) + subroutine dery_12(ty, uy, x3dop, ppy, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - real(mytype), intent(in), dimension(ny) :: ppy - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + real(mytype), intent(in), dimension(ny) :: ppy + type(x3doperator1d), intent(in) :: x3dop - call dery_ij(ty,uy,x3dop%f,x3dop%s,x3dop%w,ppy,nx,ny,nz,x3dop%npaire,1,2) + call dery_ij(ty, uy, x3dop%f, x3dop%s, x3dop%w, ppy, nx, ny, nz, x3dop%npaire, 1, 2) -end subroutine dery_12 + end subroutine dery_12 !******************************************************************** ! -subroutine dery_21(ty,uy,x3dop,ppy,nx,ny,nz) + subroutine dery_21(ty, uy, x3dop, ppy, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - real(mytype), intent(in), dimension(ny) :: ppy - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + real(mytype), intent(in), dimension(ny) :: ppy + type(x3doperator1d), intent(in) :: x3dop - call dery_ij(ty,uy,x3dop%f,x3dop%s,x3dop%w,ppy,nx,ny,nz,x3dop%npaire,2,1) + call dery_ij(ty, uy, x3dop%f, x3dop%s, x3dop%w, ppy, nx, ny, nz, x3dop%npaire, 2, 1) -end subroutine dery_21 + end subroutine dery_21 !******************************************************************** ! -subroutine dery_22(ty,uy,x3dop,ppy,nx,ny,nz) + subroutine dery_22(ty, uy, x3dop, ppy, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - real(mytype), intent(in), dimension(ny) :: ppy - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + real(mytype), intent(in), dimension(ny) :: ppy + type(x3doperator1d), intent(in) :: x3dop - call dery_ij(ty,uy,x3dop%f,x3dop%s,x3dop%w,ppy,nx,ny,nz,x3dop%npaire,2,2) + call dery_ij(ty, uy, x3dop%f, x3dop%s, x3dop%w, ppy, nx, ny, nz, x3dop%npaire, 2, 2) -end subroutine dery_22 + end subroutine dery_22 !******************************************************************** ! -subroutine derz_00(tz,uz,x3dop,nx,ny,nz) - - use x3d_operator_z_data - - implicit none - - ! Arguments - integer, intent(in) :: nx,ny,nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (nz==1) then - do concurrent(k=1:nz, j=1:ny, i=1:nx) - tz(i,j,k) = zero - enddo - return - endif - - ! Compute r.h.s. - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = afkz*(uz(i,j,2)-uz(i,j,nz )) & - + bfkz*(uz(i,j,3)-uz(i,j,nz-1)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = afkz*(uz(i,j,3)-uz(i,j,1 )) & - + bfkz*(uz(i,j,4)-uz(i,j,nz)) - enddo - do concurrent (k=3:nz-2, j=1:ny, i=1:nx) - tz(i,j,k) = afkz*(uz(i,j,k+1)-uz(i,j,k-1)) & - + bfkz*(uz(i,j,k+2)-uz(i,j,k-2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = afkz*(uz(i,j,nz)-uz(i,j,nz-2)) & - + bfkz*(uz(i,j,1 )-uz(i,j,nz-3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz) = afkz*(uz(i,j,1)-uz(i,j,nz-1)) & - + bfkz*(uz(i,j,2)-uz(i,j,nz-2)) - enddo - - ! Solve tri-diagonal system - call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - -end subroutine derz_00 + subroutine derz_00(tz, uz, x3dop, nx, ny, nz) + + use x3d_operator_z_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (nz == 1) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + tz(i, j, k) = zero + end do + return + end if + + ! Compute r.h.s. + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = afkz*(uz(i, j, 2) - uz(i, j, nz)) & + + bfkz*(uz(i, j, 3) - uz(i, j, nz - 1)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = afkz*(uz(i, j, 3) - uz(i, j, 1)) & + + bfkz*(uz(i, j, 4) - uz(i, j, nz)) + end do + do concurrent(k=3:nz - 2, j=1:ny, i=1:nx) + tz(i, j, k) = afkz*(uz(i, j, k + 1) - uz(i, j, k - 1)) & + + bfkz*(uz(i, j, k + 2) - uz(i, j, k - 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = afkz*(uz(i, j, nz) - uz(i, j, nz - 2)) & + + bfkz*(uz(i, j, 1) - uz(i, j, nz - 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = afkz*(uz(i, j, 1) - uz(i, j, nz - 1)) & + + bfkz*(uz(i, j, 2) - uz(i, j, nz - 2)) + end do + + ! Solve tri-diagonal system + call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + end subroutine derz_00 !******************************************************************** ! -subroutine derz_ij(tz,uz,ff,fs,fw,nx,ny,nz,npaire,ncl1,ncln) - - use x3d_operator_z_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - real(mytype), intent(in), dimension(nz) :: ff,fs,fw - - ! Local variables - integer :: i, j, k - - if (nz==1) then - do concurrent(k=1:nz, j=1:ny, i=1:nx) - tz(i,j,k) = zero - enddo - return - endif - - ! Compute r.h.s. - if (ncl1==1) then - if (npaire==1) then - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = zero - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = afkz*(uz(i,j,3)-uz(i,j,1)) & - + bfkz*(uz(i,j,4)-uz(i,j,2)) - enddo - else - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = afkz*(uz(i,j,2)+uz(i,j,2)) & - + bfkz*(uz(i,j,3)+uz(i,j,3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = afkz*(uz(i,j,3)-uz(i,j,1)) & - + bfkz*(uz(i,j,4)+uz(i,j,2)) - enddo - endif - else - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = af1z*uz(i,j,1) + bf1z*uz(i,j,2) & - + cf1z*uz(i,j,3) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = af2z*(uz(i,j,3)-uz(i,j,1)) - enddo - endif - do concurrent (k=3:nz-2, j=1:ny, i=1:nx) - tz(i,j,k) = afkz*(uz(i,j,k+1)-uz(i,j,k-1)) & - + bfkz*(uz(i,j,k+2)-uz(i,j,k-2)) - enddo - if (ncln==1) then - if (npaire==1) then - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = afkz*(uz(i,j,nz )-uz(i,j,nz-2)) & - + bfkz*(uz(i,j,nz-1)-uz(i,j,nz-3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz) = zero - enddo - else - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = afkz*( uz(i,j,nz )-uz(i,j,nz-2)) & - + bfkz*(-uz(i,j,nz-1)-uz(i,j,nz-3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz) = afkz*(-uz(i,j,nz-1)-uz(i,j,nz-1)) & - + bfkz*(-uz(i,j,nz-2)-uz(i,j,nz-2)) - enddo - endif - else - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = afmz*(uz(i,j,nz)-uz(i,j,nz-2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz) = - afnz*uz(i,j,nz) - bfnz*uz(i,j,nz-1) & - - cfnz*uz(i,j,nz-2) - enddo - endif - - ! Solve tri-diagonal system - call zthomas(tz, ff, fs, fw, nx, ny, nz) - -end subroutine derz_ij + subroutine derz_ij(tz, uz, ff, fs, fw, nx, ny, nz, npaire, ncl1, ncln) + + use x3d_operator_z_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + real(mytype), intent(in), dimension(nz) :: ff, fs, fw + + ! Local variables + integer :: i, j, k + + if (nz == 1) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + tz(i, j, k) = zero + end do + return + end if + + ! Compute r.h.s. + if (ncl1 == 1) then + if (npaire == 1) then + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = zero + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = afkz*(uz(i, j, 3) - uz(i, j, 1)) & + + bfkz*(uz(i, j, 4) - uz(i, j, 2)) + end do + else + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = afkz*(uz(i, j, 2) + uz(i, j, 2)) & + + bfkz*(uz(i, j, 3) + uz(i, j, 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = afkz*(uz(i, j, 3) - uz(i, j, 1)) & + + bfkz*(uz(i, j, 4) + uz(i, j, 2)) + end do + end if + else + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = af1z*uz(i, j, 1) + bf1z*uz(i, j, 2) & + + cf1z*uz(i, j, 3) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = af2z*(uz(i, j, 3) - uz(i, j, 1)) + end do + end if + do concurrent(k=3:nz - 2, j=1:ny, i=1:nx) + tz(i, j, k) = afkz*(uz(i, j, k + 1) - uz(i, j, k - 1)) & + + bfkz*(uz(i, j, k + 2) - uz(i, j, k - 2)) + end do + if (ncln == 1) then + if (npaire == 1) then + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = afkz*(uz(i, j, nz) - uz(i, j, nz - 2)) & + + bfkz*(uz(i, j, nz - 1) - uz(i, j, nz - 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = zero + end do + else + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = afkz*(uz(i, j, nz) - uz(i, j, nz - 2)) & + + bfkz*(-uz(i, j, nz - 1) - uz(i, j, nz - 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = afkz*(-uz(i, j, nz - 1) - uz(i, j, nz - 1)) & + + bfkz*(-uz(i, j, nz - 2) - uz(i, j, nz - 2)) + end do + end if + else + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = afmz*(uz(i, j, nz) - uz(i, j, nz - 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = -afnz*uz(i, j, nz) - bfnz*uz(i, j, nz - 1) & + - cfnz*uz(i, j, nz - 2) + end do + end if + + ! Solve tri-diagonal system + call zthomas(tz, ff, fs, fw, nx, ny, nz) + + end subroutine derz_ij !******************************************************************** ! -subroutine derz_11(tz,uz,x3dop,nx,ny,nz) + subroutine derz_11(tz, uz, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop - call derz_ij(tz,uz,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,1,1) + call derz_ij(tz, uz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 1, 1) -end subroutine derz_11 + end subroutine derz_11 !******************************************************************** ! -subroutine derz_12(tz,uz,x3dop,nx,ny,nz) + subroutine derz_12(tz, uz, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop - call derz_ij(tz,uz,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,1,2) + call derz_ij(tz, uz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 1, 2) -end subroutine derz_12 + end subroutine derz_12 !******************************************************************** ! -subroutine derz_21(tz,uz,x3dop,nx,ny,nz) + subroutine derz_21(tz, uz, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop - call derz_ij(tz,uz,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,2,1) + call derz_ij(tz, uz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 2, 1) -end subroutine derz_21 + end subroutine derz_21 !******************************************************************** ! -subroutine derz_22(tz,uz,x3dop,nx,ny,nz) + subroutine derz_22(tz, uz, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop - call derz_ij(tz,uz,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,2,2) + call derz_ij(tz, uz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 2, 2) -end subroutine derz_22 + end subroutine derz_22 !******************************************************************** ! -subroutine derxx_00(tx,ux,x3dop,nx,ny,nz) - - use x3d_operator_x_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - ! Compute r.h.s. - do concurrent (k=1:nz, j=1:ny) - tx(1,j,k) = asix*(ux(2,j,k)-ux(1 ,j,k) & - -ux(1,j,k)+ux(nx ,j,k)) & - + bsix*(ux(3,j,k)-ux(1 ,j,k) & - -ux(1,j,k)+ux(nx-1,j,k)) & - + csix*(ux(4,j,k)-ux(1 ,j,k) & - -ux(1,j,k)+ux(nx-2,j,k)) & - + dsix*(ux(5,j,k)-ux(1 ,j,k) & - -ux(1,j,k)+ux(nx-3,j,k)) - tx(2,j,k) = asix*(ux(3,j,k)-ux(2 ,j,k) & - -ux(2,j,k)+ux(1 ,j,k)) & - + bsix*(ux(4,j,k)-ux(2 ,j,k) & - -ux(2,j,k)+ux(nx ,j,k)) & - + csix*(ux(5,j,k)-ux(2 ,j,k) & - -ux(2,j,k)+ux(nx-1,j,k)) & - + dsix*(ux(6,j,k)-ux(2 ,j,k) & - -ux(2,j,k)+ux(nx-2,j,k)) - tx(3,j,k) = asix*(ux(4,j,k)-ux(3 ,j,k) & - -ux(3,j,k)+ux(2 ,j,k)) & - + bsix*(ux(5,j,k)-ux(3 ,j,k) & - -ux(3,j,k)+ux(1 ,j,k)) & - + csix*(ux(6,j,k)-ux(3 ,j,k) & - -ux(3,j,k)+ux(nx,j,k)) & - + dsix*(ux(7,j,k)-ux(3 ,j,k) & - -ux(3,j,k)+ux(nx-1,j,k)) - tx(4,j,k) = asix*(ux(5,j,k)-ux(4 ,j,k) & - -ux(4,j,k)+ux(3 ,j,k)) & - + bsix*(ux(6,j,k)-ux(4 ,j,k) & - -ux(4,j,k)+ux(2,j,k)) & - + csix*(ux(7,j,k)-ux(4 ,j,k) & - -ux(4,j,k)+ux(1,j,k)) & - + dsix*(ux(8,j,k)-ux(4 ,j,k) & - -ux(4,j,k)+ux(nx,j,k)) - do concurrent (i=5:nx-4) - tx(i,j,k) = asix*(ux(i+1,j,k)-ux(i ,j,k) & - -ux(i ,j,k)+ux(i-1,j,k)) & - + bsix*(ux(i+2,j,k)-ux(i ,j,k) & - -ux(i ,j,k)+ux(i-2,j,k)) & - + csix*(ux(i+3,j,k)-ux(i ,j,k) & - -ux(i ,j,k)+ux(i-3,j,k)) & - + dsix*(ux(i+4,j,k)-ux(i ,j,k) & - -ux(i ,j,k)+ux(i-4,j,k)) - enddo - tx(nx-3,j,k) = asix*(ux(nx-2,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-4,j,k)) & - + bsix*(ux(nx-1,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-5,j,k)) & - + csix*(ux(nx ,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-6,j,k)) & - + dsix*(ux(1 ,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-7,j,k)) - tx(nx-2,j,k) = asix*(ux(nx-1,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-3,j,k)) & - + bsix*(ux(nx ,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-4,j,k)) & - + csix*(ux(1 ,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-5,j,k)) & - + dsix*(ux(2 ,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-6,j,k)) - tx(nx-1,j,k) = asix*(ux(nx ,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-2,j,k)) & - + bsix*(ux(1 ,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-3,j,k)) & - + csix*(ux(2 ,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-4,j,k)) & - + dsix*(ux(3 ,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-5,j,k)) - tx(nx ,j,k) = asix*(ux(1 ,j,k)-ux(nx ,j,k) & - -ux(nx,j,k)+ux(nx-1,j,k)) & - + bsix*(ux(2 ,j,k)-ux(nx ,j,k) & - -ux(nx,j,k)+ux(nx-2,j,k)) & - + csix*(ux(3 ,j,k)-ux(nx ,j,k) & - -ux(nx,j,k)+ux(nx-3,j,k)) & - + dsix*(ux(4 ,j,k)-ux(nx ,j,k) & - -ux(nx,j,k)+ux(nx-4,j,k)) - enddo - - ! Solve tri-diagonal system - call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - -end subroutine derxx_00 + subroutine derxx_00(tx, ux, x3dop, nx, ny, nz) + + use x3d_operator_x_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + ! Compute r.h.s. + do concurrent(k=1:nz, j=1:ny) + tx(1, j, k) = asix*(ux(2, j, k) - ux(1, j, k) & + - ux(1, j, k) + ux(nx, j, k)) & + + bsix*(ux(3, j, k) - ux(1, j, k) & + - ux(1, j, k) + ux(nx - 1, j, k)) & + + csix*(ux(4, j, k) - ux(1, j, k) & + - ux(1, j, k) + ux(nx - 2, j, k)) & + + dsix*(ux(5, j, k) - ux(1, j, k) & + - ux(1, j, k) + ux(nx - 3, j, k)) + tx(2, j, k) = asix*(ux(3, j, k) - ux(2, j, k) & + - ux(2, j, k) + ux(1, j, k)) & + + bsix*(ux(4, j, k) - ux(2, j, k) & + - ux(2, j, k) + ux(nx, j, k)) & + + csix*(ux(5, j, k) - ux(2, j, k) & + - ux(2, j, k) + ux(nx - 1, j, k)) & + + dsix*(ux(6, j, k) - ux(2, j, k) & + - ux(2, j, k) + ux(nx - 2, j, k)) + tx(3, j, k) = asix*(ux(4, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(2, j, k)) & + + bsix*(ux(5, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(1, j, k)) & + + csix*(ux(6, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(nx, j, k)) & + + dsix*(ux(7, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(nx - 1, j, k)) + tx(4, j, k) = asix*(ux(5, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(3, j, k)) & + + bsix*(ux(6, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(2, j, k)) & + + csix*(ux(7, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(1, j, k)) & + + dsix*(ux(8, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(nx, j, k)) + do concurrent(i=5:nx - 4) + tx(i, j, k) = asix*(ux(i + 1, j, k) - ux(i, j, k) & + - ux(i, j, k) + ux(i - 1, j, k)) & + + bsix*(ux(i + 2, j, k) - ux(i, j, k) & + - ux(i, j, k) + ux(i - 2, j, k)) & + + csix*(ux(i + 3, j, k) - ux(i, j, k) & + - ux(i, j, k) + ux(i - 3, j, k)) & + + dsix*(ux(i + 4, j, k) - ux(i, j, k) & + - ux(i, j, k) + ux(i - 4, j, k)) + end do + tx(nx - 3, j, k) = asix*(ux(nx - 2, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 4, j, k)) & + + bsix*(ux(nx - 1, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 5, j, k)) & + + csix*(ux(nx, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 6, j, k)) & + + dsix*(ux(1, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 7, j, k)) + tx(nx - 2, j, k) = asix*(ux(nx - 1, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 3, j, k)) & + + bsix*(ux(nx, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 4, j, k)) & + + csix*(ux(1, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 5, j, k)) & + + dsix*(ux(2, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 6, j, k)) + tx(nx - 1, j, k) = asix*(ux(nx, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 2, j, k)) & + + bsix*(ux(1, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 3, j, k)) & + + csix*(ux(2, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 4, j, k)) & + + dsix*(ux(3, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 5, j, k)) + tx(nx, j, k) = asix*(ux(1, j, k) - ux(nx, j, k) & + - ux(nx, j, k) + ux(nx - 1, j, k)) & + + bsix*(ux(2, j, k) - ux(nx, j, k) & + - ux(nx, j, k) + ux(nx - 2, j, k)) & + + csix*(ux(3, j, k) - ux(nx, j, k) & + - ux(nx, j, k) + ux(nx - 3, j, k)) & + + dsix*(ux(4, j, k) - ux(nx, j, k) & + - ux(nx, j, k) + ux(nx - 4, j, k)) + end do + + ! Solve tri-diagonal system + call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + end subroutine derxx_00 !******************************************************************** ! -subroutine derxx_ij(tx,ux,sf,ss,sw,nx,ny,nz,npaire,ncl1,ncln) - - use x3d_operator_x_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - real(mytype), intent(in), dimension(nx):: sf,ss,sw - - ! Local variables - integer :: i, j, k - - do concurrent (k=1:nz, j=1:ny) - - ! Compute r.h.s. - if (ncl1==1) then - if (npaire==1) then - tx(1,j,k) = asix*(ux(2,j,k)-ux(1,j,k) & - -ux(1,j,k)+ux(2,j,k)) & - + bsix*(ux(3,j,k)-ux(1,j,k) & - -ux(1,j,k)+ux(3,j,k)) & - + csix*(ux(4,j,k)-ux(1,j,k) & - -ux(1,j,k)+ux(4,j,k)) & - + dsix*(ux(5,j,k)-ux(1,j,k) & - -ux(1,j,k)+ux(5,j,k)) - tx(2,j,k) = asix*(ux(3,j,k)-ux(2,j,k) & - -ux(2,j,k)+ux(1,j,k)) & - + bsix*(ux(4,j,k)-ux(2,j,k) & - -ux(2,j,k)+ux(2,j,k)) & - + csix*(ux(5,j,k)-ux(2,j,k) & - -ux(2,j,k)+ux(3,j,k)) & - + dsix*(ux(6,j,k)-ux(2,j,k) & - -ux(2,j,k)+ux(4,j,k)) - tx(3,j,k) = asix*(ux(4,j,k)-ux(3,j,k) & - -ux(3,j,k)+ux(2,j,k)) & - + bsix*(ux(5,j,k)-ux(3,j,k) & - -ux(3,j,k)+ux(1,j,k)) & - + csix*(ux(6,j,k)-ux(3,j,k) & - -ux(3,j,k)+ux(2,j,k)) & - + dsix*(ux(7,j,k)-ux(3,j,k) & - -ux(3,j,k)+ux(3,j,k)) - tx(4,j,k) = asix*(ux(5,j,k)-ux(4,j,k) & - -ux(4,j,k)+ux(3,j,k)) & - + bsix*(ux(6,j,k)-ux(4,j,k) & - -ux(4,j,k)+ux(2,j,k)) & - + csix*(ux(7,j,k)-ux(4,j,k) & - -ux(4,j,k)+ux(1,j,k)) & - + dsix*(ux(8,j,k)-ux(4,j,k) & - -ux(4,j,k)+ux(2,j,k)) - else - tx(1,j,k) = zero - tx(2,j,k) = asix*(ux(3,j,k)-ux(2,j,k) & - -ux(2,j,k)+ux(1,j,k)) & - + bsix*(ux(4,j,k)-ux(2,j,k) & - -ux(2,j,k)-ux(2,j,k)) & - + csix*(ux(5,j,k)-ux(2,j,k) & - -ux(2,j,k)-ux(3,j,k)) & - + dsix*(ux(6,j,k)-ux(2,j,k) & - -ux(2,j,k)-ux(4,j,k)) - tx(3,j,k) = asix*(ux(4,j,k)-ux(3,j,k) & - -ux(3,j,k)+ux(2,j,k)) & - + bsix*(ux(5,j,k)-ux(3,j,k) & - -ux(3,j,k)+ux(1,j,k)) & - + csix*(ux(6,j,k)-ux(3,j,k) & - -ux(3,j,k)-ux(2,j,k)) & - + dsix*(ux(7,j,k)-ux(3,j,k) & - -ux(3,j,k)-ux(3,j,k)) - tx(4,j,k) = asix*(ux(5,j,k)-ux(4,j,k) & - -ux(4,j,k)+ux(3,j,k)) & - + bsix*(ux(6,j,k)-ux(4,j,k) & - -ux(4,j,k)+ux(2,j,k)) & - + csix*(ux(7,j,k)-ux(4,j,k) & - -ux(4,j,k)-ux(1,j,k)) & - + dsix*(ux(8,j,k)-ux(4,j,k) & - -ux(4,j,k)-ux(2,j,k)) - endif - else - tx(1,j,k) = as1x*ux(1,j,k) + bs1x*ux(2,j,k) & - + cs1x*ux(3,j,k) + ds1x*ux(4,j,k) - tx(2,j,k) = as2x*(ux(3,j,k)-ux(2,j,k) & - -ux(2,j,k)+ux(1,j,k)) - tx(3,j,k) = as3x*(ux(4,j,k)-ux(3,j,k) & - -ux(3,j,k)+ux(2,j,k)) & - + bs3x*(ux(5,j,k)-ux(3,j,k) & - -ux(3,j,k)+ux(1,j,k)) - tx(4,j,k) = as4x*(ux(5,j,k)-ux(4,j,k) & - -ux(4,j,k)+ux(3,j,k)) & - + bs4x*(ux(6,j,k)-ux(4,j,k) & - -ux(4,j,k)+ux(2,j,k)) & - + cs4x*(ux(7,j,k)-ux(4,j,k) & - -ux(4,j,k)+ux(1,j,k)) - endif - do concurrent (i=5:nx-4) - tx(i,j,k) = asix*(ux(i+1,j,k)-ux(i ,j,k) & - -ux(i ,j,k)+ux(i-1,j,k)) & - + bsix*(ux(i+2,j,k)-ux(i ,j,k) & - -ux(i ,j,k)+ux(i-2,j,k)) & - + csix*(ux(i+3,j,k)-ux(i ,j,k) & - -ux(i ,j,k)+ux(i-3,j,k)) & - + dsix*(ux(i+4,j,k)-ux(i ,j,k) & - -ux(i ,j,k)+ux(i-4,j,k)) - enddo - if (ncln == 1) then - if (npaire==1) then - tx(nx-3,j,k) = asix*(ux(nx-2,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-4,j,k)) & - + bsix*(ux(nx-1,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-5,j,k)) & - + csix*(ux(nx ,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-6,j,k)) & - + dsix*(ux(nx-1,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-7,j,k)) - tx(nx-2,j,k) = asix*(ux(nx-1,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-3,j,k)) & - + bsix*(ux(nx ,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-4,j,k)) & - + csix*(ux(nx-1,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-5,j,k)) & - + dsix*(ux(nx-2,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-6,j,k)) - tx(nx-1,j,k) = asix*(ux(nx ,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-2,j,k)) & - + bsix*(ux(nx-1,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-3,j,k)) & - + csix*(ux(nx-2,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-4,j,k)) & - + dsix*(ux(nx-3,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-5,j,k)) - tx(nx ,j,k) = asix*(ux(nx-1,j,k)-ux(nx ,j,k) & - -ux(nx ,j,k)+ux(nx-1,j,k)) & - + bsix*(ux(nx-2,j,k)-ux(nx ,j,k) & - -ux(nx ,j,k)+ux(nx-2,j,k)) & - + csix*(ux(nx-3,j,k)-ux(nx ,j,k) & - -ux(nx ,j,k)+ux(nx-3,j,k)) & - + dsix*(ux(nx-4,j,k)-ux(nx ,j,k) & - -ux(nx ,j,k)+ux(nx-4,j,k)) - else - tx(nx-3,j,k) = asix*( ux(nx-2,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-4,j,k)) & - + bsix*( ux(nx-1,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-5,j,k)) & - + csix*(-ux(nx ,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-6,j,k)) & - + dsix*(-ux(nx-1,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-7,j,k)) - tx(nx-2,j,k) = asix*( ux(nx-1,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-3,j,k)) & - + bsix*( ux(nx ,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-4,j,k)) & - + csix*(-ux(nx-1,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-5,j,k)) & - + dsix*(-ux(nx-2,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-6,j,k)) - tx(nx-1,j,k) = asix*( ux(nx ,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-2,j,k)) & - + bsix*(-ux(nx-1,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-3,j,k)) & - + csix*(-ux(nx-2,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-4,j,k)) & - + dsix*(-ux(nx-3,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-5,j,k)) - tx(nx ,j,k) = zero - endif - else - tx(nx-3,j,k) = asttx*(ux(nx-2,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-4,j,k)) & - + bsttx*(ux(nx-1,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-5,j,k)) & - + csttx*(ux(nx,j,k)-ux(nx-3,j,k) & - -ux(nx-3,j,k)+ux(nx-6,j,k)) - tx(nx-2,j,k) = astx*(ux(nx-1,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-3,j,k)) & - + bstx*(ux(nx ,j,k)-ux(nx-2,j,k) & - -ux(nx-2,j,k)+ux(nx-4,j,k)) - tx(nx-1,j,k) = asmx*(ux(nx ,j,k)-ux(nx-1,j,k) & - -ux(nx-1,j,k)+ux(nx-2,j,k)) - tx(nx ,j,k) = asnx*ux(nx ,j,k) + bsnx*ux(nx-1,j,k) & - + csnx*ux(nx-2,j,k) + dsnx*ux(nx-3,j,k) - endif - enddo - - ! Solve tri-diagonal system - call xthomas(tx, sf, ss, sw, nx, ny, nz) - -end subroutine derxx_ij + subroutine derxx_ij(tx, ux, sf, ss, sw, nx, ny, nz, npaire, ncl1, ncln) + + use x3d_operator_x_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + real(mytype), intent(in), dimension(nx):: sf, ss, sw + + ! Local variables + integer :: i, j, k + + do concurrent(k=1:nz, j=1:ny) + + ! Compute r.h.s. + if (ncl1 == 1) then + if (npaire == 1) then + tx(1, j, k) = asix*(ux(2, j, k) - ux(1, j, k) & + - ux(1, j, k) + ux(2, j, k)) & + + bsix*(ux(3, j, k) - ux(1, j, k) & + - ux(1, j, k) + ux(3, j, k)) & + + csix*(ux(4, j, k) - ux(1, j, k) & + - ux(1, j, k) + ux(4, j, k)) & + + dsix*(ux(5, j, k) - ux(1, j, k) & + - ux(1, j, k) + ux(5, j, k)) + tx(2, j, k) = asix*(ux(3, j, k) - ux(2, j, k) & + - ux(2, j, k) + ux(1, j, k)) & + + bsix*(ux(4, j, k) - ux(2, j, k) & + - ux(2, j, k) + ux(2, j, k)) & + + csix*(ux(5, j, k) - ux(2, j, k) & + - ux(2, j, k) + ux(3, j, k)) & + + dsix*(ux(6, j, k) - ux(2, j, k) & + - ux(2, j, k) + ux(4, j, k)) + tx(3, j, k) = asix*(ux(4, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(2, j, k)) & + + bsix*(ux(5, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(1, j, k)) & + + csix*(ux(6, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(2, j, k)) & + + dsix*(ux(7, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(3, j, k)) + tx(4, j, k) = asix*(ux(5, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(3, j, k)) & + + bsix*(ux(6, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(2, j, k)) & + + csix*(ux(7, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(1, j, k)) & + + dsix*(ux(8, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(2, j, k)) + else + tx(1, j, k) = zero + tx(2, j, k) = asix*(ux(3, j, k) - ux(2, j, k) & + - ux(2, j, k) + ux(1, j, k)) & + + bsix*(ux(4, j, k) - ux(2, j, k) & + - ux(2, j, k) - ux(2, j, k)) & + + csix*(ux(5, j, k) - ux(2, j, k) & + - ux(2, j, k) - ux(3, j, k)) & + + dsix*(ux(6, j, k) - ux(2, j, k) & + - ux(2, j, k) - ux(4, j, k)) + tx(3, j, k) = asix*(ux(4, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(2, j, k)) & + + bsix*(ux(5, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(1, j, k)) & + + csix*(ux(6, j, k) - ux(3, j, k) & + - ux(3, j, k) - ux(2, j, k)) & + + dsix*(ux(7, j, k) - ux(3, j, k) & + - ux(3, j, k) - ux(3, j, k)) + tx(4, j, k) = asix*(ux(5, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(3, j, k)) & + + bsix*(ux(6, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(2, j, k)) & + + csix*(ux(7, j, k) - ux(4, j, k) & + - ux(4, j, k) - ux(1, j, k)) & + + dsix*(ux(8, j, k) - ux(4, j, k) & + - ux(4, j, k) - ux(2, j, k)) + end if + else + tx(1, j, k) = as1x*ux(1, j, k) + bs1x*ux(2, j, k) & + + cs1x*ux(3, j, k) + ds1x*ux(4, j, k) + tx(2, j, k) = as2x*(ux(3, j, k) - ux(2, j, k) & + - ux(2, j, k) + ux(1, j, k)) + tx(3, j, k) = as3x*(ux(4, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(2, j, k)) & + + bs3x*(ux(5, j, k) - ux(3, j, k) & + - ux(3, j, k) + ux(1, j, k)) + tx(4, j, k) = as4x*(ux(5, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(3, j, k)) & + + bs4x*(ux(6, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(2, j, k)) & + + cs4x*(ux(7, j, k) - ux(4, j, k) & + - ux(4, j, k) + ux(1, j, k)) + end if + do concurrent(i=5:nx - 4) + tx(i, j, k) = asix*(ux(i + 1, j, k) - ux(i, j, k) & + - ux(i, j, k) + ux(i - 1, j, k)) & + + bsix*(ux(i + 2, j, k) - ux(i, j, k) & + - ux(i, j, k) + ux(i - 2, j, k)) & + + csix*(ux(i + 3, j, k) - ux(i, j, k) & + - ux(i, j, k) + ux(i - 3, j, k)) & + + dsix*(ux(i + 4, j, k) - ux(i, j, k) & + - ux(i, j, k) + ux(i - 4, j, k)) + end do + if (ncln == 1) then + if (npaire == 1) then + tx(nx - 3, j, k) = asix*(ux(nx - 2, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 4, j, k)) & + + bsix*(ux(nx - 1, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 5, j, k)) & + + csix*(ux(nx, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 6, j, k)) & + + dsix*(ux(nx - 1, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 7, j, k)) + tx(nx - 2, j, k) = asix*(ux(nx - 1, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 3, j, k)) & + + bsix*(ux(nx, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 4, j, k)) & + + csix*(ux(nx - 1, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 5, j, k)) & + + dsix*(ux(nx - 2, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 6, j, k)) + tx(nx - 1, j, k) = asix*(ux(nx, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 2, j, k)) & + + bsix*(ux(nx - 1, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 3, j, k)) & + + csix*(ux(nx - 2, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 4, j, k)) & + + dsix*(ux(nx - 3, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 5, j, k)) + tx(nx, j, k) = asix*(ux(nx - 1, j, k) - ux(nx, j, k) & + - ux(nx, j, k) + ux(nx - 1, j, k)) & + + bsix*(ux(nx - 2, j, k) - ux(nx, j, k) & + - ux(nx, j, k) + ux(nx - 2, j, k)) & + + csix*(ux(nx - 3, j, k) - ux(nx, j, k) & + - ux(nx, j, k) + ux(nx - 3, j, k)) & + + dsix*(ux(nx - 4, j, k) - ux(nx, j, k) & + - ux(nx, j, k) + ux(nx - 4, j, k)) + else + tx(nx - 3, j, k) = asix*(ux(nx - 2, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 4, j, k)) & + + bsix*(ux(nx - 1, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 5, j, k)) & + + csix*(-ux(nx, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 6, j, k)) & + + dsix*(-ux(nx - 1, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 7, j, k)) + tx(nx - 2, j, k) = asix*(ux(nx - 1, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 3, j, k)) & + + bsix*(ux(nx, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 4, j, k)) & + + csix*(-ux(nx - 1, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 5, j, k)) & + + dsix*(-ux(nx - 2, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 6, j, k)) + tx(nx - 1, j, k) = asix*(ux(nx, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 2, j, k)) & + + bsix*(-ux(nx - 1, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 3, j, k)) & + + csix*(-ux(nx - 2, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 4, j, k)) & + + dsix*(-ux(nx - 3, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 5, j, k)) + tx(nx, j, k) = zero + end if + else + tx(nx - 3, j, k) = asttx*(ux(nx - 2, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 4, j, k)) & + + bsttx*(ux(nx - 1, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 5, j, k)) & + + csttx*(ux(nx, j, k) - ux(nx - 3, j, k) & + - ux(nx - 3, j, k) + ux(nx - 6, j, k)) + tx(nx - 2, j, k) = astx*(ux(nx - 1, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 3, j, k)) & + + bstx*(ux(nx, j, k) - ux(nx - 2, j, k) & + - ux(nx - 2, j, k) + ux(nx - 4, j, k)) + tx(nx - 1, j, k) = asmx*(ux(nx, j, k) - ux(nx - 1, j, k) & + - ux(nx - 1, j, k) + ux(nx - 2, j, k)) + tx(nx, j, k) = asnx*ux(nx, j, k) + bsnx*ux(nx - 1, j, k) & + + csnx*ux(nx - 2, j, k) + dsnx*ux(nx - 3, j, k) + end if + end do + + ! Solve tri-diagonal system + call xthomas(tx, sf, ss, sw, nx, ny, nz) + + end subroutine derxx_ij !******************************************************************** ! -subroutine derxx_11(tx,ux,x3dop,nx,ny,nz) + subroutine derxx_11(tx, ux, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx,ny,nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop - call derxx_ij(tx,ux,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,1,1) + call derxx_ij(tx, ux, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 1, 1) -end subroutine derxx_11 + end subroutine derxx_11 !******************************************************************** ! -subroutine derxx_12(tx,ux,x3dop,nx,ny,nz) + subroutine derxx_12(tx, ux, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx,ny,nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop - call derxx_ij(tx,ux,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,1,2) + call derxx_ij(tx, ux, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 1, 2) -end subroutine derxx_12 + end subroutine derxx_12 !******************************************************************** ! -subroutine derxx_21(tx,ux,x3dop,nx,ny,nz) + subroutine derxx_21(tx, ux, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx,ny,nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop - call derxx_ij(tx,ux,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,2,1) + call derxx_ij(tx, ux, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 2, 1) -end subroutine derxx_21 + end subroutine derxx_21 !******************************************************************** ! -subroutine derxx_22(tx,ux,x3dop,nx,ny,nz) + subroutine derxx_22(tx, ux, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx,ny,nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop - call derxx_ij(tx,ux,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,2,2) + call derxx_ij(tx, ux, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 2, 2) -end subroutine derxx_22 + end subroutine derxx_22 !******************************************************************** ! -subroutine deryy_00(ty,uy,x3dop,nx,ny,nz) - - use x3d_operator_y_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - ! Compute r.h.s. - do concurrent (k=1:nz) - do concurrent (i=1:nx) - ty(i,1,k) = asjy*(uy(i,2,k)-uy(i,1,k) & - -uy(i,1,k)+uy(i,ny,k)) & - + bsjy*(uy(i,3,k)-uy(i,1,k) & - -uy(i,1,k)+uy(i,ny-1,k)) & - + csjy*(uy(i,4,k)-uy(i,1,k) & - -uy(i,1,k)+uy(i,ny-2,k)) & - + dsjy*(uy(i,5,k)-uy(i,1,k) & - -uy(i,1,k)+uy(i,ny-3,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = asjy*(uy(i,3,k)-uy(i,2,k) & - -uy(i,2,k)+uy(i,1,k)) & - + bsjy*(uy(i,4,k)-uy(i,2,k) & - -uy(i,2,k)+uy(i,ny,k)) & - + csjy*(uy(i,5,k)-uy(i,2,k) & - -uy(i,2,k)+uy(i,ny-1,k)) & - + dsjy*(uy(i,6,k)-uy(i,2,k) & - -uy(i,2,k)+uy(i,ny-2,k)) - enddo - do concurrent (i=1:nx) - ty(i,3,k) = asjy*(uy(i,4,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,2,k)) & - + bsjy*(uy(i,5,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,1,k)) & - + csjy*(uy(i,6,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,ny,k)) & - + dsjy*(uy(i,7,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,ny-1,k)) - enddo - do concurrent (i=1:nx) - ty(i,4,k) = asjy*(uy(i,5,k)-uy(i,4,k) & - -uy(i,4,k)+uy(i,3,k)) & - + bsjy*(uy(i,6,k)-uy(i,4,k) & - -uy(i,4,k)+uy(i,2,k)) & - + csjy*(uy(i,7,k)-uy(i,4,k) & - -uy(i,4,k)+uy(i,1,k)) & - + dsjy*(uy(i,8,k)-uy(i,4,k) & - -uy(i,4,k)+uy(i,ny,k)) - enddo - do concurrent (j=5:ny-4, i=1:nx) - ty(i,j,k) = asjy*(uy(i,j+1,k)-uy(i,j,k) & - -uy(i,j,k)+uy(i,j-1,k)) & - + bsjy*(uy(i,j+2,k)-uy(i,j,k) & - -uy(i,j,k)+uy(i,j-2,k)) & - + csjy*(uy(i,j+3,k)-uy(i,j,k) & - -uy(i,j,k)+uy(i,j-3,k)) & - + dsjy*(uy(i,j+4,k)-uy(i,j,k) & - -uy(i,j,k)+uy(i,j-4,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-3,k) = asjy*(uy(i,ny-2,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-4,k)) & - + bsjy*(uy(i,ny-1,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-5,k)) & - + csjy*(uy(i,ny ,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-6,k)) & - + dsjy*(uy(i,1 ,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-7,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-2,k) = asjy*(uy(i,ny-1,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-3,k)) & - + bsjy*(uy(i,ny ,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-4,k)) & - + csjy*(uy(i,1 ,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-5,k)) & - + dsjy*(uy(i,2 ,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-6,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = asjy*(uy(i,ny ,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-2,k)) & - + bsjy*(uy(i,1 ,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-3,k)) & - + csjy*(uy(i,2 ,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-4,k)) & - + dsjy*(uy(i,3 ,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-5,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny ,k) = asjy*(uy(i,1 ,k)-uy(i,ny ,k) & - -uy(i,ny,k)+uy(i,ny-1,k)) & - + bsjy*(uy(i,2 ,k)-uy(i,ny ,k) & - -uy(i,ny,k)+uy(i,ny-2,k)) & - + csjy*(uy(i,3 ,k)-uy(i,ny ,k) & - -uy(i,ny,k)+uy(i,ny-3,k)) & - + dsjy*(uy(i,4 ,k)-uy(i,ny ,k) & - -uy(i,ny,k)+uy(i,ny-4,k)) - enddo - enddo - - ! Solve tri-diagonal system - call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - -end subroutine deryy_00 + subroutine deryy_00(ty, uy, x3dop, nx, ny, nz) + + use x3d_operator_y_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + ! Compute r.h.s. + do concurrent(k=1:nz) + do concurrent(i=1:nx) + ty(i, 1, k) = asjy*(uy(i, 2, k) - uy(i, 1, k) & + - uy(i, 1, k) + uy(i, ny, k)) & + + bsjy*(uy(i, 3, k) - uy(i, 1, k) & + - uy(i, 1, k) + uy(i, ny - 1, k)) & + + csjy*(uy(i, 4, k) - uy(i, 1, k) & + - uy(i, 1, k) + uy(i, ny - 2, k)) & + + dsjy*(uy(i, 5, k) - uy(i, 1, k) & + - uy(i, 1, k) + uy(i, ny - 3, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = asjy*(uy(i, 3, k) - uy(i, 2, k) & + - uy(i, 2, k) + uy(i, 1, k)) & + + bsjy*(uy(i, 4, k) - uy(i, 2, k) & + - uy(i, 2, k) + uy(i, ny, k)) & + + csjy*(uy(i, 5, k) - uy(i, 2, k) & + - uy(i, 2, k) + uy(i, ny - 1, k)) & + + dsjy*(uy(i, 6, k) - uy(i, 2, k) & + - uy(i, 2, k) + uy(i, ny - 2, k)) + end do + do concurrent(i=1:nx) + ty(i, 3, k) = asjy*(uy(i, 4, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, 2, k)) & + + bsjy*(uy(i, 5, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, 1, k)) & + + csjy*(uy(i, 6, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, ny, k)) & + + dsjy*(uy(i, 7, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, ny - 1, k)) + end do + do concurrent(i=1:nx) + ty(i, 4, k) = asjy*(uy(i, 5, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 3, k)) & + + bsjy*(uy(i, 6, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 2, k)) & + + csjy*(uy(i, 7, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 1, k)) & + + dsjy*(uy(i, 8, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, ny, k)) + end do + do concurrent(j=5:ny - 4, i=1:nx) + ty(i, j, k) = asjy*(uy(i, j + 1, k) - uy(i, j, k) & + - uy(i, j, k) + uy(i, j - 1, k)) & + + bsjy*(uy(i, j + 2, k) - uy(i, j, k) & + - uy(i, j, k) + uy(i, j - 2, k)) & + + csjy*(uy(i, j + 3, k) - uy(i, j, k) & + - uy(i, j, k) + uy(i, j - 3, k)) & + + dsjy*(uy(i, j + 4, k) - uy(i, j, k) & + - uy(i, j, k) + uy(i, j - 4, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 3, k) = asjy*(uy(i, ny - 2, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 4, k)) & + + bsjy*(uy(i, ny - 1, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 5, k)) & + + csjy*(uy(i, ny, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 6, k)) & + + dsjy*(uy(i, 1, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 7, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 2, k) = asjy*(uy(i, ny - 1, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 3, k)) & + + bsjy*(uy(i, ny, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 4, k)) & + + csjy*(uy(i, 1, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 5, k)) & + + dsjy*(uy(i, 2, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 6, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = asjy*(uy(i, ny, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 2, k)) & + + bsjy*(uy(i, 1, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 3, k)) & + + csjy*(uy(i, 2, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 4, k)) & + + dsjy*(uy(i, 3, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 5, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = asjy*(uy(i, 1, k) - uy(i, ny, k) & + - uy(i, ny, k) + uy(i, ny - 1, k)) & + + bsjy*(uy(i, 2, k) - uy(i, ny, k) & + - uy(i, ny, k) + uy(i, ny - 2, k)) & + + csjy*(uy(i, 3, k) - uy(i, ny, k) & + - uy(i, ny, k) + uy(i, ny - 3, k)) & + + dsjy*(uy(i, 4, k) - uy(i, ny, k) & + - uy(i, ny, k) + uy(i, ny - 4, k)) + end do + end do + + ! Solve tri-diagonal system + call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + end subroutine deryy_00 !******************************************************************** ! -subroutine deryy_ij(ty,uy,sf,ss,sw,nx,ny,nz,npaire,ncl1,ncln) - - use x3d_operator_y_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - real(mytype), intent(in), dimension(ny) :: sf,ss,sw - - ! Local variables - integer :: i, j, k - - ! Compute r.h.s. - do concurrent (k=1:nz) - if (ncl1==1) then - if (npaire==1) then - do concurrent (i=1:nx) - ty(i,1,k) = asjy*(uy(i,2,k)-uy(i,1,k) & - -uy(i,1,k)+uy(i,2,k)) & - + bsjy*(uy(i,3,k)-uy(i,1,k) & - -uy(i,1,k)+uy(i,3,k)) & - + csjy*(uy(i,4,k)-uy(i,1,k) & - -uy(i,1,k)+uy(i,4,k)) & - + dsjy*(uy(i,5,k)-uy(i,1,k) & - -uy(i,1,k)+uy(i,5,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = asjy*(uy(i,3,k)-uy(i,2,k) & - -uy(i,2,k)+uy(i,1,k)) & - + bsjy*(uy(i,4,k)-uy(i,2,k) & - -uy(i,2,k)+uy(i,2,k)) & - + csjy*(uy(i,5,k)-uy(i,2,k) & - -uy(i,2,k)+uy(i,3,k)) & - + dsjy*(uy(i,6,k)-uy(i,2,k) & - -uy(i,2,k)+uy(i,4,k)) - enddo - do concurrent (i=1:nx) - ty(i,3,k) = asjy*(uy(i,4,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,2,k)) & - + bsjy*(uy(i,5,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,1,k)) & - + csjy*(uy(i,6,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,2,k)) & - + dsjy*(uy(i,7,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,3,k)) - enddo - do concurrent (i=1:nx) - ty(i,4,k) = asjy*(uy(i,5,k)-uy(i,4,k) & - -uy(i,4,k)+uy(i,3,k)) & - + bsjy*(uy(i,6,k)-uy(i,4,k) & - -uy(i,4,k)+uy(i,2,k)) & - + csjy*(uy(i,7,k)-uy(i,4,k) & - -uy(i,4,k)+uy(i,1,k)) & - + dsjy*(uy(i,8,k)-uy(i,4,k) & - -uy(i,4,k)+uy(i,2,k)) - enddo - else - do concurrent (i=1:nx) - ty(i,1,k) = zero - enddo - do concurrent (i=1:nx) - ty(i,2,k) = asjy*(uy(i,3,k)-uy(i,2,k) & - -uy(i,2,k)+uy(i,1,k)) & - + bsjy*(uy(i,4,k)-uy(i,2,k) & - -uy(i,2,k)-uy(i,2,k)) & - + csjy*(uy(i,5,k)-uy(i,2,k) & - -uy(i,2,k)-uy(i,3,k)) & - + dsjy*(uy(i,6,k)-uy(i,2,k) & - -uy(i,2,k)-uy(i,4,k)) - enddo - do concurrent (i=1:nx) - ty(i,3,k) = asjy*(uy(i,4,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,2,k)) & - + bsjy*(uy(i,5,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,1,k)) & - + csjy*(uy(i,6,k)-uy(i,3,k) & - -uy(i,3,k)-uy(i,2,k)) & - + dsjy*(uy(i,7,k)-uy(i,3,k) & - -uy(i,3,k)-uy(i,3,k)) - enddo - do concurrent (i=1:nx) - ty(i,4,k) = asjy*(uy(i,5,k)-uy(i,4,k) & - -uy(i,4,k)+uy(i,3,k)) & - + bsjy*(uy(i,6,k)-uy(i,4,k) & - -uy(i,4,k)+uy(i,2,k)) & - + csjy*(uy(i,7,k)-uy(i,4,k) & - -uy(i,4,k)-uy(i,1,k)) & - + dsjy*(uy(i,8,k)-uy(i,4,k) & - -uy(i,4,k)-uy(i,2,k)) - enddo - endif - else - do concurrent (i=1:nx) - ty(i,1,k) = as1y*uy(i,1,k) + bs1y*uy(i,2,k) & - + cs1y*uy(i,3,k) + ds1y*uy(i,4,k) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = as2y*(uy(i,3,k)-uy(i,2,k) & - -uy(i,2,k)+uy(i,1,k)) - enddo - do concurrent (i=1:nx) - ty(i,3,k) = as3y*(uy(i,4,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,2,k)) & - + bs3y*(uy(i,5,k)-uy(i,3,k) & - -uy(i,3,k)+uy(i,1,k)) - enddo - do concurrent (i=1:nx) - ty(i,4,k) = as4y*(uy(i,5,k)-uy(i,4,k) & - -uy(i,4 ,k)+uy(i,3,k)) & - + bs4y*(uy(i,6,k)-uy(i,4 ,k) & - -uy(i,4 ,k)+uy(i,2,k)) & - + cs4y*(uy(i,7,k)-uy(i,4 ,k) & - -uy(i,4 ,k)+uy(i,1,k)) - enddo - endif - do concurrent (j=5:ny-4, i=1:nx) - ty(i,j,k) = asjy*(uy(i,j+1,k)-uy(i,j ,k) & - -uy(i,j ,k)+uy(i,j-1,k)) & - + bsjy*(uy(i,j+2,k)-uy(i,j ,k) & - -uy(i,j ,k)+uy(i,j-2,k)) & - + csjy*(uy(i,j+3,k)-uy(i,j ,k) & - -uy(i,j ,k)+uy(i,j-3,k)) & - + dsjy*(uy(i,j+4,k)-uy(i,j ,k) & - -uy(i,j ,k)+uy(i,j-4,k)) - enddo - if (ncln==1) then - if (npaire==1) then - do concurrent (i=1:nx) - ty(i,ny-3,k) = asjy*(uy(i,ny-2,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-4,k)) & - + bsjy*(uy(i,ny-1,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-5,k)) & - + csjy*(uy(i,ny ,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-6,k)) & - + dsjy*(uy(i,ny-1,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-7,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-2,k) = asjy*(uy(i,ny-1,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-3,k)) & - + bsjy*(uy(i,ny ,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-4,k)) & - + csjy*(uy(i,ny-1,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-5,k)) & - + dsjy*(uy(i,ny-2,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-6,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = asjy*(uy(i,ny ,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-2,k)) & - + bsjy*(uy(i,ny-1,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-3,k)) & - + csjy*(uy(i,ny-2,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-4,k)) & - + dsjy*(uy(i,ny-3,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-5,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny ,k) = asjy*(uy(i,ny-1,k)-uy(i,ny ,k) & - -uy(i,ny ,k)+uy(i,ny-1,k)) & - + bsjy*(uy(i,ny-2,k)-uy(i,ny ,k) & - -uy(i,ny ,k)+uy(i,ny-2,k)) & - + csjy*(uy(i,ny-3,k)-uy(i,ny ,k) & - -uy(i,ny ,k)+uy(i,ny-3,k)) & - + dsjy*(uy(i,ny-4,k)-uy(i,ny ,k) & - -uy(i,ny ,k)+uy(i,ny-4,k)) - enddo - else - do concurrent (i=1:nx) - ty(i,ny-3,k) = asjy*( uy(i,ny-2,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-4,k)) & - + bsjy*( uy(i,ny-1,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-5,k)) & - + csjy*(-uy(i,ny ,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-6,k)) & - + dsjy*(-uy(i,ny-1,k)-uy(i,ny-3,k) & - -uy(i,ny-3,k)+uy(i,ny-7,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-2,k) = asjy*( uy(i,ny-1,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-3,k)) & - + bsjy*( uy(i,ny ,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-4,k)) & - + csjy*(-uy(i,ny-1,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-5,k)) & - + dsjy*(-uy(i,ny-2,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-6,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = asjy*( uy(i,ny ,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-2,k)) & - + bsjy*(-uy(i,ny-1,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-3,k)) & - + csjy*(-uy(i,ny-2,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-4,k)) & - + dsjy*(-uy(i,ny-3,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-5,k)) - ty(i,ny ,k) = zero - enddo - endif - else - do concurrent (i=1:nx) - ty(i,ny-3,k) = astty*(uy(i,ny-2,k)-uy(i,ny-3 ,k) & - -uy(i,ny-3 ,k)+uy(i,ny-4,k)) & - + bstty*(uy(i,ny-1,k)-uy(i,ny-3 ,k) & - -uy(i,ny-3 ,k)+uy(i,ny-5,k)) & - + cstty*(uy(i,ny,k)-uy(i,ny-3 ,k) & - -uy(i,ny-3 ,k)+uy(i,ny-6,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-2,k) = asty*(uy(i,ny-1,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-3,k)) & - + bsty*(uy(i,ny ,k)-uy(i,ny-2,k) & - -uy(i,ny-2,k)+uy(i,ny-4,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = asmy*(uy(i,ny ,k)-uy(i,ny-1,k) & - -uy(i,ny-1,k)+uy(i,ny-2,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny ,k) = asny*uy(i,ny ,k) + bsny*uy(i,ny-1,k) & - + csny*uy(i,ny-2,k) + dsny*uy(i,ny-3,k) - enddo - endif - enddo - - ! Solve tri-diagonal system - call ythomas(ty, sf, ss, sw, nx, ny, nz) - -end subroutine deryy_ij + subroutine deryy_ij(ty, uy, sf, ss, sw, nx, ny, nz, npaire, ncl1, ncln) + + use x3d_operator_y_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + real(mytype), intent(in), dimension(ny) :: sf, ss, sw + + ! Local variables + integer :: i, j, k + + ! Compute r.h.s. + do concurrent(k=1:nz) + if (ncl1 == 1) then + if (npaire == 1) then + do concurrent(i=1:nx) + ty(i, 1, k) = asjy*(uy(i, 2, k) - uy(i, 1, k) & + - uy(i, 1, k) + uy(i, 2, k)) & + + bsjy*(uy(i, 3, k) - uy(i, 1, k) & + - uy(i, 1, k) + uy(i, 3, k)) & + + csjy*(uy(i, 4, k) - uy(i, 1, k) & + - uy(i, 1, k) + uy(i, 4, k)) & + + dsjy*(uy(i, 5, k) - uy(i, 1, k) & + - uy(i, 1, k) + uy(i, 5, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = asjy*(uy(i, 3, k) - uy(i, 2, k) & + - uy(i, 2, k) + uy(i, 1, k)) & + + bsjy*(uy(i, 4, k) - uy(i, 2, k) & + - uy(i, 2, k) + uy(i, 2, k)) & + + csjy*(uy(i, 5, k) - uy(i, 2, k) & + - uy(i, 2, k) + uy(i, 3, k)) & + + dsjy*(uy(i, 6, k) - uy(i, 2, k) & + - uy(i, 2, k) + uy(i, 4, k)) + end do + do concurrent(i=1:nx) + ty(i, 3, k) = asjy*(uy(i, 4, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, 2, k)) & + + bsjy*(uy(i, 5, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, 1, k)) & + + csjy*(uy(i, 6, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, 2, k)) & + + dsjy*(uy(i, 7, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, 3, k)) + end do + do concurrent(i=1:nx) + ty(i, 4, k) = asjy*(uy(i, 5, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 3, k)) & + + bsjy*(uy(i, 6, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 2, k)) & + + csjy*(uy(i, 7, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 1, k)) & + + dsjy*(uy(i, 8, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 2, k)) + end do + else + do concurrent(i=1:nx) + ty(i, 1, k) = zero + end do + do concurrent(i=1:nx) + ty(i, 2, k) = asjy*(uy(i, 3, k) - uy(i, 2, k) & + - uy(i, 2, k) + uy(i, 1, k)) & + + bsjy*(uy(i, 4, k) - uy(i, 2, k) & + - uy(i, 2, k) - uy(i, 2, k)) & + + csjy*(uy(i, 5, k) - uy(i, 2, k) & + - uy(i, 2, k) - uy(i, 3, k)) & + + dsjy*(uy(i, 6, k) - uy(i, 2, k) & + - uy(i, 2, k) - uy(i, 4, k)) + end do + do concurrent(i=1:nx) + ty(i, 3, k) = asjy*(uy(i, 4, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, 2, k)) & + + bsjy*(uy(i, 5, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, 1, k)) & + + csjy*(uy(i, 6, k) - uy(i, 3, k) & + - uy(i, 3, k) - uy(i, 2, k)) & + + dsjy*(uy(i, 7, k) - uy(i, 3, k) & + - uy(i, 3, k) - uy(i, 3, k)) + end do + do concurrent(i=1:nx) + ty(i, 4, k) = asjy*(uy(i, 5, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 3, k)) & + + bsjy*(uy(i, 6, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 2, k)) & + + csjy*(uy(i, 7, k) - uy(i, 4, k) & + - uy(i, 4, k) - uy(i, 1, k)) & + + dsjy*(uy(i, 8, k) - uy(i, 4, k) & + - uy(i, 4, k) - uy(i, 2, k)) + end do + end if + else + do concurrent(i=1:nx) + ty(i, 1, k) = as1y*uy(i, 1, k) + bs1y*uy(i, 2, k) & + + cs1y*uy(i, 3, k) + ds1y*uy(i, 4, k) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = as2y*(uy(i, 3, k) - uy(i, 2, k) & + - uy(i, 2, k) + uy(i, 1, k)) + end do + do concurrent(i=1:nx) + ty(i, 3, k) = as3y*(uy(i, 4, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, 2, k)) & + + bs3y*(uy(i, 5, k) - uy(i, 3, k) & + - uy(i, 3, k) + uy(i, 1, k)) + end do + do concurrent(i=1:nx) + ty(i, 4, k) = as4y*(uy(i, 5, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 3, k)) & + + bs4y*(uy(i, 6, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 2, k)) & + + cs4y*(uy(i, 7, k) - uy(i, 4, k) & + - uy(i, 4, k) + uy(i, 1, k)) + end do + end if + do concurrent(j=5:ny - 4, i=1:nx) + ty(i, j, k) = asjy*(uy(i, j + 1, k) - uy(i, j, k) & + - uy(i, j, k) + uy(i, j - 1, k)) & + + bsjy*(uy(i, j + 2, k) - uy(i, j, k) & + - uy(i, j, k) + uy(i, j - 2, k)) & + + csjy*(uy(i, j + 3, k) - uy(i, j, k) & + - uy(i, j, k) + uy(i, j - 3, k)) & + + dsjy*(uy(i, j + 4, k) - uy(i, j, k) & + - uy(i, j, k) + uy(i, j - 4, k)) + end do + if (ncln == 1) then + if (npaire == 1) then + do concurrent(i=1:nx) + ty(i, ny - 3, k) = asjy*(uy(i, ny - 2, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 4, k)) & + + bsjy*(uy(i, ny - 1, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 5, k)) & + + csjy*(uy(i, ny, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 6, k)) & + + dsjy*(uy(i, ny - 1, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 7, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 2, k) = asjy*(uy(i, ny - 1, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 3, k)) & + + bsjy*(uy(i, ny, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 4, k)) & + + csjy*(uy(i, ny - 1, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 5, k)) & + + dsjy*(uy(i, ny - 2, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 6, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = asjy*(uy(i, ny, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 2, k)) & + + bsjy*(uy(i, ny - 1, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 3, k)) & + + csjy*(uy(i, ny - 2, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 4, k)) & + + dsjy*(uy(i, ny - 3, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 5, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = asjy*(uy(i, ny - 1, k) - uy(i, ny, k) & + - uy(i, ny, k) + uy(i, ny - 1, k)) & + + bsjy*(uy(i, ny - 2, k) - uy(i, ny, k) & + - uy(i, ny, k) + uy(i, ny - 2, k)) & + + csjy*(uy(i, ny - 3, k) - uy(i, ny, k) & + - uy(i, ny, k) + uy(i, ny - 3, k)) & + + dsjy*(uy(i, ny - 4, k) - uy(i, ny, k) & + - uy(i, ny, k) + uy(i, ny - 4, k)) + end do + else + do concurrent(i=1:nx) + ty(i, ny - 3, k) = asjy*(uy(i, ny - 2, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 4, k)) & + + bsjy*(uy(i, ny - 1, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 5, k)) & + + csjy*(-uy(i, ny, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 6, k)) & + + dsjy*(-uy(i, ny - 1, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 7, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 2, k) = asjy*(uy(i, ny - 1, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 3, k)) & + + bsjy*(uy(i, ny, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 4, k)) & + + csjy*(-uy(i, ny - 1, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 5, k)) & + + dsjy*(-uy(i, ny - 2, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 6, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = asjy*(uy(i, ny, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 2, k)) & + + bsjy*(-uy(i, ny - 1, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 3, k)) & + + csjy*(-uy(i, ny - 2, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 4, k)) & + + dsjy*(-uy(i, ny - 3, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 5, k)) + ty(i, ny, k) = zero + end do + end if + else + do concurrent(i=1:nx) + ty(i, ny - 3, k) = astty*(uy(i, ny - 2, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 4, k)) & + + bstty*(uy(i, ny - 1, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 5, k)) & + + cstty*(uy(i, ny, k) - uy(i, ny - 3, k) & + - uy(i, ny - 3, k) + uy(i, ny - 6, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 2, k) = asty*(uy(i, ny - 1, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 3, k)) & + + bsty*(uy(i, ny, k) - uy(i, ny - 2, k) & + - uy(i, ny - 2, k) + uy(i, ny - 4, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = asmy*(uy(i, ny, k) - uy(i, ny - 1, k) & + - uy(i, ny - 1, k) + uy(i, ny - 2, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = asny*uy(i, ny, k) + bsny*uy(i, ny - 1, k) & + + csny*uy(i, ny - 2, k) + dsny*uy(i, ny - 3, k) + end do + end if + end do + + ! Solve tri-diagonal system + call ythomas(ty, sf, ss, sw, nx, ny, nz) + + end subroutine deryy_ij !******************************************************************** ! -subroutine deryy_11(ty,uy,x3dop,nx,ny,nz) + subroutine deryy_11(ty, uy, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + type(x3doperator1d), intent(in) :: x3dop - call deryy_ij(ty,uy,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,1,1) + call deryy_ij(ty, uy, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 1, 1) -end subroutine deryy_11 + end subroutine deryy_11 !******************************************************************** ! -subroutine deryy_12(ty,uy,x3dop,nx,ny,nz) + subroutine deryy_12(ty, uy, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + type(x3doperator1d), intent(in) :: x3dop - call deryy_ij(ty,uy,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,1,2) + call deryy_ij(ty, uy, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 1, 2) -end subroutine deryy_12 + end subroutine deryy_12 !******************************************************************** ! -subroutine deryy_21(ty,uy,x3dop,nx,ny,nz) + subroutine deryy_21(ty, uy, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + type(x3doperator1d), intent(in) :: x3dop - call deryy_ij(ty,uy,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,2,1) + call deryy_ij(ty, uy, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 2, 1) -end subroutine deryy_21 + end subroutine deryy_21 !******************************************************************** ! -subroutine deryy_22(ty,uy,x3dop,nx,ny,nz) + subroutine deryy_22(ty, uy, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + type(x3doperator1d), intent(in) :: x3dop - call deryy_ij(ty,uy,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,2,2) + call deryy_ij(ty, uy, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 2, 2) -end subroutine deryy_22 + end subroutine deryy_22 !******************************************************************** ! -subroutine derzz_00(tz,uz,x3dop,nx,ny,nz) - - use x3d_operator_z_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (nz==1) then - do concurrent(k=1:nz, j=1:ny, i=1:nx) - tz(i,j,k) = zero - enddo - return - endif - - ! Compute r.h.s. - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = askz*(uz(i,j,2)-uz(i,j,1 ) & - -uz(i,j,1)+uz(i,j,nz )) & - + bskz*(uz(i,j,3)-uz(i,j,1 ) & - -uz(i,j,1)+uz(i,j,nz-1)) & - + cskz*(uz(i,j,4)-uz(i,j,1 ) & - -uz(i,j,1)+uz(i,j,nz-2)) & - + dskz*(uz(i,j,5)-uz(i,j,1 ) & - -uz(i,j,1)+uz(i,j,nz-3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = askz*(uz(i,j,3)-uz(i,j,2 ) & - -uz(i,j,2)+uz(i,j,1 )) & - + bskz*(uz(i,j,4)-uz(i,j,2 ) & - -uz(i,j,2)+uz(i,j,nz)) & - + cskz*(uz(i,j,5)-uz(i,j,2 ) & - -uz(i,j,2)+uz(i,j,nz-1)) & - + dskz*(uz(i,j,6)-uz(i,j,2 ) & - -uz(i,j,2)+uz(i,j,nz-2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,3) = askz*(uz(i,j,4)-uz(i,j,3 ) & - -uz(i,j,3)+uz(i,j,2 )) & - + bskz*(uz(i,j,5)-uz(i,j,3 ) & - -uz(i,j,3)+uz(i,j,1 )) & - + cskz*(uz(i,j,6)-uz(i,j,3 ) & - -uz(i,j,3)+uz(i,j,nz)) & - + dskz*(uz(i,j,7)-uz(i,j,3 ) & - -uz(i,j,3)+uz(i,j,nz-1)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,4) = askz*(uz(i,j,5)-uz(i,j,4 ) & - -uz(i,j,4)+uz(i,j,3 )) & - + bskz*(uz(i,j,6)-uz(i,j,4 ) & - -uz(i,j,4)+uz(i,j,2 )) & - + cskz*(uz(i,j,7)-uz(i,j,4 ) & - -uz(i,j,4)+uz(i,j,1)) & - + dskz*(uz(i,j,8)-uz(i,j,4 ) & - -uz(i,j,4)+uz(i,j,nz)) - enddo - do concurrent (k=5:nz-4, j=1:ny, i=1:nx) - tz(i,j,k) = askz*(uz(i,j,k+1)-uz(i,j,k ) & - -uz(i,j,k )+uz(i,j,k-1)) & - + bskz*(uz(i,j,k+2)-uz(i,j,k ) & - -uz(i,j,k )+uz(i,j,k-2)) & - + cskz*(uz(i,j,k+3)-uz(i,j,k ) & - -uz(i,j,k )+uz(i,j,k-3)) & - + dskz*(uz(i,j,k+4)-uz(i,j,k ) & - -uz(i,j,k )+uz(i,j,k-4)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-3) = askz*(uz(i,j,nz-2)-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-4)) & - + bskz*(uz(i,j,nz-1 )-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-5)) & - + cskz*(uz(i,j,nz )-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-6)) & - + dskz*(uz(i,j,1 )-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-7)) - tz(i,j,nz-2) = askz*(uz(i,j,nz-1)-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-3)) & - + bskz*(uz(i,j,nz )-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-4)) & - + cskz*(uz(i,j,1 )-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-5)) & - + dskz*(uz(i,j,2 )-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-6)) - tz(i,j,nz-1) = askz*(uz(i,j,nz )-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-2)) & - + bskz*(uz(i,j,1 )-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-3)) & - + cskz*(uz(i,j,2 )-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-4)) & - + dskz*(uz(i,j,3 )-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-5)) - tz(i,j,nz ) = askz*(uz(i,j,1 )-uz(i,j,nz ) & - -uz(i,j,nz)+uz(i,j,nz-1)) & - + bskz*(uz(i,j,2 )-uz(i,j,nz ) & - -uz(i,j,nz)+uz(i,j,nz-2)) & - + cskz*(uz(i,j,3 )-uz(i,j,nz ) & - -uz(i,j,nz)+uz(i,j,nz-3)) & - + dskz*(uz(i,j,4 )-uz(i,j,nz ) & - -uz(i,j,nz)+uz(i,j,nz-4)) - enddo - - ! Solve tri-diagonal system - call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - -end subroutine derzz_00 + subroutine derzz_00(tz, uz, x3dop, nx, ny, nz) + + use x3d_operator_z_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (nz == 1) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + tz(i, j, k) = zero + end do + return + end if + + ! Compute r.h.s. + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = askz*(uz(i, j, 2) - uz(i, j, 1) & + - uz(i, j, 1) + uz(i, j, nz)) & + + bskz*(uz(i, j, 3) - uz(i, j, 1) & + - uz(i, j, 1) + uz(i, j, nz - 1)) & + + cskz*(uz(i, j, 4) - uz(i, j, 1) & + - uz(i, j, 1) + uz(i, j, nz - 2)) & + + dskz*(uz(i, j, 5) - uz(i, j, 1) & + - uz(i, j, 1) + uz(i, j, nz - 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = askz*(uz(i, j, 3) - uz(i, j, 2) & + - uz(i, j, 2) + uz(i, j, 1)) & + + bskz*(uz(i, j, 4) - uz(i, j, 2) & + - uz(i, j, 2) + uz(i, j, nz)) & + + cskz*(uz(i, j, 5) - uz(i, j, 2) & + - uz(i, j, 2) + uz(i, j, nz - 1)) & + + dskz*(uz(i, j, 6) - uz(i, j, 2) & + - uz(i, j, 2) + uz(i, j, nz - 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 3) = askz*(uz(i, j, 4) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, 2)) & + + bskz*(uz(i, j, 5) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, 1)) & + + cskz*(uz(i, j, 6) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, nz)) & + + dskz*(uz(i, j, 7) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, nz - 1)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 4) = askz*(uz(i, j, 5) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 3)) & + + bskz*(uz(i, j, 6) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 2)) & + + cskz*(uz(i, j, 7) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 1)) & + + dskz*(uz(i, j, 8) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, nz)) + end do + do concurrent(k=5:nz - 4, j=1:ny, i=1:nx) + tz(i, j, k) = askz*(uz(i, j, k + 1) - uz(i, j, k) & + - uz(i, j, k) + uz(i, j, k - 1)) & + + bskz*(uz(i, j, k + 2) - uz(i, j, k) & + - uz(i, j, k) + uz(i, j, k - 2)) & + + cskz*(uz(i, j, k + 3) - uz(i, j, k) & + - uz(i, j, k) + uz(i, j, k - 3)) & + + dskz*(uz(i, j, k + 4) - uz(i, j, k) & + - uz(i, j, k) + uz(i, j, k - 4)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 3) = askz*(uz(i, j, nz - 2) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 4)) & + + bskz*(uz(i, j, nz - 1) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 5)) & + + cskz*(uz(i, j, nz) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 6)) & + + dskz*(uz(i, j, 1) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 7)) + tz(i, j, nz - 2) = askz*(uz(i, j, nz - 1) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 3)) & + + bskz*(uz(i, j, nz) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 4)) & + + cskz*(uz(i, j, 1) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 5)) & + + dskz*(uz(i, j, 2) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 6)) + tz(i, j, nz - 1) = askz*(uz(i, j, nz) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 2)) & + + bskz*(uz(i, j, 1) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 3)) & + + cskz*(uz(i, j, 2) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 4)) & + + dskz*(uz(i, j, 3) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 5)) + tz(i, j, nz) = askz*(uz(i, j, 1) - uz(i, j, nz) & + - uz(i, j, nz) + uz(i, j, nz - 1)) & + + bskz*(uz(i, j, 2) - uz(i, j, nz) & + - uz(i, j, nz) + uz(i, j, nz - 2)) & + + cskz*(uz(i, j, 3) - uz(i, j, nz) & + - uz(i, j, nz) + uz(i, j, nz - 3)) & + + dskz*(uz(i, j, 4) - uz(i, j, nz) & + - uz(i, j, nz) + uz(i, j, nz - 4)) + end do + + ! Solve tri-diagonal system + call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + end subroutine derzz_00 !******************************************************************** ! -subroutine derzz_ij(tz,uz,sf,ss,sw,nx,ny,nz,npaire,ncl1,ncln) - - use x3d_operator_z_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - real(mytype), intent(in), dimension(nz) :: sf,ss,sw - - ! Local variables - integer :: i, j, k - - if (nz==1) then - do concurrent(k=1:nz, j=1:ny, i=1:nx) - tz(i,j,k) = zero - enddo - endif - - ! Compute r.h.s. - if (ncl1==1) then - if (npaire==1) then - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = askz*(uz(i,j,2)-uz(i,j,1) & - -uz(i,j,1)+uz(i,j,2)) & - + bskz*(uz(i,j,3)-uz(i,j,1) & - -uz(i,j,1)+uz(i,j,3)) & - + cskz*(uz(i,j,4)-uz(i,j,1) & - -uz(i,j,1)+uz(i,j,4)) & - + dskz*(uz(i,j,5)-uz(i,j,1) & - -uz(i,j,1)+uz(i,j,5)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = askz*(uz(i,j,3)-uz(i,j,2) & - -uz(i,j,2)+uz(i,j,1)) & - + bskz*(uz(i,j,4)-uz(i,j,2) & - -uz(i,j,2)+uz(i,j,2)) & - + cskz*(uz(i,j,5)-uz(i,j,2) & - -uz(i,j,2)+uz(i,j,3)) & - + dskz*(uz(i,j,6)-uz(i,j,2) & - -uz(i,j,2)+uz(i,j,4)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,3) = askz*(uz(i,j,4)-uz(i,j,3) & - -uz(i,j,3)+uz(i,j,2)) & - + bskz*(uz(i,j,5)-uz(i,j,3) & - -uz(i,j,3)+uz(i,j,1)) & - + cskz*(uz(i,j,6)-uz(i,j,3) & - -uz(i,j,3)+uz(i,j,2)) & - + dskz*(uz(i,j,7)-uz(i,j,3) & - -uz(i,j,3)+uz(i,j,3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,4) = askz*(uz(i,j,5)-uz(i,j,4) & - -uz(i,j,4)+uz(i,j,3)) & - + bskz*(uz(i,j,6)-uz(i,j,4) & - -uz(i,j,4)+uz(i,j,2)) & - + cskz*(uz(i,j,7)-uz(i,j,4) & - -uz(i,j,4)+uz(i,j,1)) & - + dskz*(uz(i,j,8)-uz(i,j,4) & - -uz(i,j,4)+uz(i,j,2)) - enddo - else - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = zero - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = askz*(uz(i,j,3)-uz(i,j,2) & - -uz(i,j,2)+uz(i,j,1)) & - + bskz*(uz(i,j,4)-uz(i,j,2) & - -uz(i,j,2)-uz(i,j,2)) & - + cskz*(uz(i,j,5)-uz(i,j,2) & - -uz(i,j,2)-uz(i,j,3)) & - + dskz*(uz(i,j,6)-uz(i,j,2) & - -uz(i,j,2)-uz(i,j,4)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,3) = askz*(uz(i,j,4)-uz(i,j,3) & - -uz(i,j,3)+uz(i,j,2)) & - + bskz*(uz(i,j,5)-uz(i,j,3) & - -uz(i,j,3)+uz(i,j,1)) & - + cskz*(uz(i,j,6)-uz(i,j,3) & - -uz(i,j,3)-uz(i,j,2)) & - + dskz*(uz(i,j,7)-uz(i,j,3) & - -uz(i,j,3)-uz(i,j,3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,4) = askz*(uz(i,j,5)-uz(i,j,4) & - -uz(i,j,4)+uz(i,j,3)) & - + bskz*(uz(i,j,6)-uz(i,j,4) & - -uz(i,j,4)+uz(i,j,2)) & - + cskz*(uz(i,j,7)-uz(i,j,4) & - -uz(i,j,4)-uz(i,j,1)) & - + dskz*(uz(i,j,8)-uz(i,j,4) & - -uz(i,j,4)-uz(i,j,2)) - enddo - endif - else - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = as1z*uz(i,j,1) + bs1z*uz(i,j,2) & - + cs1z*uz(i,j,3) + ds1z*uz(i,j,4) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = as2z*(uz(i,j,3)-uz(i,j,2) & - -uz(i,j,2)+uz(i,j,1)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,3) = as3z*(uz(i,j,4)-uz(i,j,3) & - -uz(i,j,3)+uz(i,j,2)) & - + bs3z*(uz(i,j,5)-uz(i,j,3) & - -uz(i,j,3)+uz(i,j,1)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,4) = as4z*(uz(i,j,5)-uz(i,j,4 ) & - -uz(i,j,4 )+uz(i,j,3)) & - + bs4z*(uz(i,j,6)-uz(i,j,4 ) & - -uz(i,j,4 )+uz(i,j,2)) & - + cs4z*(uz(i,j,7)-uz(i,j,4 ) & - -uz(i,j,4 )+uz(i,j,1)) - enddo - endif - do concurrent (k=5:nz-4, j=1:ny, i=1:nx) - tz(i,j,k) = askz*(uz(i,j,k+1)-uz(i,j,k ) & - -uz(i,j,k )+uz(i,j,k-1)) & - + bskz*(uz(i,j,k+2)-uz(i,j,k ) & - -uz(i,j,k )+uz(i,j,k-2)) & - + cskz*(uz(i,j,k+3)-uz(i,j,k ) & - -uz(i,j,k )+uz(i,j,k-3)) & - + dskz*(uz(i,j,k+4)-uz(i,j,k ) & - -uz(i,j,k )+uz(i,j,k-4)) - enddo - if (ncln==1) then - if (npaire==1) then - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-3) = askz*(uz(i,j,nz-2)-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-4)) & - + bskz*(uz(i,j,nz-1)-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-5)) & - + cskz*(uz(i,j,nz )-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-6)) & - + dskz*(uz(i,j,nz-1)-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-7)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-2) = askz*(uz(i,j,nz-1)-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-3)) & - + bskz*(uz(i,j,nz )-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-4)) & - + cskz*(uz(i,j,nz-1)-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-5)) & - + dskz*(uz(i,j,nz-2)-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-6)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = askz*(uz(i,j,nz )-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-2)) & - + bskz*(uz(i,j,nz-1)-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-3)) & - + cskz*(uz(i,j,nz-2)-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-4)) & - + dskz*(uz(i,j,nz-3)-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-5)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz ) = askz*(uz(i,j,nz-1)-uz(i,j,nz ) & - -uz(i,j,nz )+uz(i,j,nz-1)) & - + bskz*(uz(i,j,nz-2)-uz(i,j,nz ) & - -uz(i,j,nz )+uz(i,j,nz-2)) & - + cskz*(uz(i,j,nz-3)-uz(i,j,nz ) & - -uz(i,j,nz )+uz(i,j,nz-3)) & - + dskz*(uz(i,j,nz-4)-uz(i,j,nz ) & - -uz(i,j,nz )+uz(i,j,nz-4)) - enddo - else - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-3) = askz*( uz(i,j,nz-2)-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-4)) & - + bskz*( uz(i,j,nz-1)-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-5)) & - + cskz*(-uz(i,j,nz )-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-6)) & - + dskz*(-uz(i,j,nz-1)-uz(i,j,nz-3) & - -uz(i,j,nz-3)+uz(i,j,nz-7)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-2) = askz*( uz(i,j,nz-1)-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-3)) & - + bskz*( uz(i,j,nz )-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-4)) & - + cskz*(-uz(i,j,nz-1)-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-5)) & - + dskz*(-uz(i,j,nz-2)-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-6)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = askz*( uz(i,j,nz )-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-2)) & - + bskz*(-uz(i,j,nz-1)-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-3)) & - + cskz*(-uz(i,j,nz-2)-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-4)) & - + dskz*(-uz(i,j,nz-3)-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-5)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz ) = zero - enddo - endif - else - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-3) = asttz*(uz(i,j,nz-2)-uz(i,j,nz-3 ) & - -uz(i,j,nz-3 )+uz(i,j,nz-4)) & - + bsttz*(uz(i,j,nz-1)-uz(i,j,nz-3 ) & - -uz(i,j,nz-3 )+uz(i,j,nz-5)) & - + csttz*(uz(i,j,nz)-uz(i,j,nz-3 ) & - -uz(i,j,nz-3 )+uz(i,j,nz-6)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-2) = astz*(uz(i,j,nz-1)-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-3)) & - + bstz*(uz(i,j,nz )-uz(i,j,nz-2) & - -uz(i,j,nz-2)+uz(i,j,nz-4)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = asmz*(uz(i,j,nz )-uz(i,j,nz-1) & - -uz(i,j,nz-1)+uz(i,j,nz-2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz ) = asnz*uz(i,j,nz ) + bsnz*uz(i,j,nz-1) & - + csnz*uz(i,j,nz-2) + dsnz*uz(i,j,nz-3) - enddo - endif - - ! Solve tri-diagonal system - call zthomas(tz, sf, ss, sw, nx, ny, nz) - -end subroutine derzz_ij + subroutine derzz_ij(tz, uz, sf, ss, sw, nx, ny, nz, npaire, ncl1, ncln) + + use x3d_operator_z_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz, npaire, ncl1, ncln + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + real(mytype), intent(in), dimension(nz) :: sf, ss, sw + + ! Local variables + integer :: i, j, k + + if (nz == 1) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + tz(i, j, k) = zero + end do + end if + + ! Compute r.h.s. + if (ncl1 == 1) then + if (npaire == 1) then + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = askz*(uz(i, j, 2) - uz(i, j, 1) & + - uz(i, j, 1) + uz(i, j, 2)) & + + bskz*(uz(i, j, 3) - uz(i, j, 1) & + - uz(i, j, 1) + uz(i, j, 3)) & + + cskz*(uz(i, j, 4) - uz(i, j, 1) & + - uz(i, j, 1) + uz(i, j, 4)) & + + dskz*(uz(i, j, 5) - uz(i, j, 1) & + - uz(i, j, 1) + uz(i, j, 5)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = askz*(uz(i, j, 3) - uz(i, j, 2) & + - uz(i, j, 2) + uz(i, j, 1)) & + + bskz*(uz(i, j, 4) - uz(i, j, 2) & + - uz(i, j, 2) + uz(i, j, 2)) & + + cskz*(uz(i, j, 5) - uz(i, j, 2) & + - uz(i, j, 2) + uz(i, j, 3)) & + + dskz*(uz(i, j, 6) - uz(i, j, 2) & + - uz(i, j, 2) + uz(i, j, 4)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 3) = askz*(uz(i, j, 4) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, 2)) & + + bskz*(uz(i, j, 5) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, 1)) & + + cskz*(uz(i, j, 6) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, 2)) & + + dskz*(uz(i, j, 7) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 4) = askz*(uz(i, j, 5) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 3)) & + + bskz*(uz(i, j, 6) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 2)) & + + cskz*(uz(i, j, 7) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 1)) & + + dskz*(uz(i, j, 8) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 2)) + end do + else + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = zero + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = askz*(uz(i, j, 3) - uz(i, j, 2) & + - uz(i, j, 2) + uz(i, j, 1)) & + + bskz*(uz(i, j, 4) - uz(i, j, 2) & + - uz(i, j, 2) - uz(i, j, 2)) & + + cskz*(uz(i, j, 5) - uz(i, j, 2) & + - uz(i, j, 2) - uz(i, j, 3)) & + + dskz*(uz(i, j, 6) - uz(i, j, 2) & + - uz(i, j, 2) - uz(i, j, 4)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 3) = askz*(uz(i, j, 4) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, 2)) & + + bskz*(uz(i, j, 5) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, 1)) & + + cskz*(uz(i, j, 6) - uz(i, j, 3) & + - uz(i, j, 3) - uz(i, j, 2)) & + + dskz*(uz(i, j, 7) - uz(i, j, 3) & + - uz(i, j, 3) - uz(i, j, 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 4) = askz*(uz(i, j, 5) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 3)) & + + bskz*(uz(i, j, 6) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 2)) & + + cskz*(uz(i, j, 7) - uz(i, j, 4) & + - uz(i, j, 4) - uz(i, j, 1)) & + + dskz*(uz(i, j, 8) - uz(i, j, 4) & + - uz(i, j, 4) - uz(i, j, 2)) + end do + end if + else + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = as1z*uz(i, j, 1) + bs1z*uz(i, j, 2) & + + cs1z*uz(i, j, 3) + ds1z*uz(i, j, 4) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = as2z*(uz(i, j, 3) - uz(i, j, 2) & + - uz(i, j, 2) + uz(i, j, 1)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 3) = as3z*(uz(i, j, 4) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, 2)) & + + bs3z*(uz(i, j, 5) - uz(i, j, 3) & + - uz(i, j, 3) + uz(i, j, 1)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 4) = as4z*(uz(i, j, 5) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 3)) & + + bs4z*(uz(i, j, 6) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 2)) & + + cs4z*(uz(i, j, 7) - uz(i, j, 4) & + - uz(i, j, 4) + uz(i, j, 1)) + end do + end if + do concurrent(k=5:nz - 4, j=1:ny, i=1:nx) + tz(i, j, k) = askz*(uz(i, j, k + 1) - uz(i, j, k) & + - uz(i, j, k) + uz(i, j, k - 1)) & + + bskz*(uz(i, j, k + 2) - uz(i, j, k) & + - uz(i, j, k) + uz(i, j, k - 2)) & + + cskz*(uz(i, j, k + 3) - uz(i, j, k) & + - uz(i, j, k) + uz(i, j, k - 3)) & + + dskz*(uz(i, j, k + 4) - uz(i, j, k) & + - uz(i, j, k) + uz(i, j, k - 4)) + end do + if (ncln == 1) then + if (npaire == 1) then + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 3) = askz*(uz(i, j, nz - 2) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 4)) & + + bskz*(uz(i, j, nz - 1) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 5)) & + + cskz*(uz(i, j, nz) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 6)) & + + dskz*(uz(i, j, nz - 1) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 7)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 2) = askz*(uz(i, j, nz - 1) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 3)) & + + bskz*(uz(i, j, nz) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 4)) & + + cskz*(uz(i, j, nz - 1) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 5)) & + + dskz*(uz(i, j, nz - 2) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 6)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = askz*(uz(i, j, nz) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 2)) & + + bskz*(uz(i, j, nz - 1) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 3)) & + + cskz*(uz(i, j, nz - 2) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 4)) & + + dskz*(uz(i, j, nz - 3) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 5)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = askz*(uz(i, j, nz - 1) - uz(i, j, nz) & + - uz(i, j, nz) + uz(i, j, nz - 1)) & + + bskz*(uz(i, j, nz - 2) - uz(i, j, nz) & + - uz(i, j, nz) + uz(i, j, nz - 2)) & + + cskz*(uz(i, j, nz - 3) - uz(i, j, nz) & + - uz(i, j, nz) + uz(i, j, nz - 3)) & + + dskz*(uz(i, j, nz - 4) - uz(i, j, nz) & + - uz(i, j, nz) + uz(i, j, nz - 4)) + end do + else + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 3) = askz*(uz(i, j, nz - 2) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 4)) & + + bskz*(uz(i, j, nz - 1) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 5)) & + + cskz*(-uz(i, j, nz) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 6)) & + + dskz*(-uz(i, j, nz - 1) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 7)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 2) = askz*(uz(i, j, nz - 1) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 3)) & + + bskz*(uz(i, j, nz) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 4)) & + + cskz*(-uz(i, j, nz - 1) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 5)) & + + dskz*(-uz(i, j, nz - 2) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 6)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = askz*(uz(i, j, nz) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 2)) & + + bskz*(-uz(i, j, nz - 1) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 3)) & + + cskz*(-uz(i, j, nz - 2) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 4)) & + + dskz*(-uz(i, j, nz - 3) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 5)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = zero + end do + end if + else + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 3) = asttz*(uz(i, j, nz - 2) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 4)) & + + bsttz*(uz(i, j, nz - 1) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 5)) & + + csttz*(uz(i, j, nz) - uz(i, j, nz - 3) & + - uz(i, j, nz - 3) + uz(i, j, nz - 6)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 2) = astz*(uz(i, j, nz - 1) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 3)) & + + bstz*(uz(i, j, nz) - uz(i, j, nz - 2) & + - uz(i, j, nz - 2) + uz(i, j, nz - 4)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = asmz*(uz(i, j, nz) - uz(i, j, nz - 1) & + - uz(i, j, nz - 1) + uz(i, j, nz - 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = asnz*uz(i, j, nz) + bsnz*uz(i, j, nz - 1) & + + csnz*uz(i, j, nz - 2) + dsnz*uz(i, j, nz - 3) + end do + end if + + ! Solve tri-diagonal system + call zthomas(tz, sf, ss, sw, nx, ny, nz) + + end subroutine derzz_ij !******************************************************************** ! -subroutine derzz_11(tz,uz,x3dop,nx,ny,nz) + subroutine derzz_11(tz, uz, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop - call derzz_ij(tz,uz,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,1,1) + call derzz_ij(tz, uz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 1, 1) -end subroutine derzz_11 + end subroutine derzz_11 !******************************************************************** ! -subroutine derzz_12(tz,uz,x3dop,nx,ny,nz) + subroutine derzz_12(tz, uz, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop - call derzz_ij(tz,uz,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,1,2) + call derzz_ij(tz, uz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 1, 2) -end subroutine derzz_12 + end subroutine derzz_12 !******************************************************************** ! -subroutine derzz_21(tz,uz,x3dop,nx,ny,nz) + subroutine derzz_21(tz, uz, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop - call derzz_ij(tz,uz,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,2,1) + call derzz_ij(tz, uz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 2, 1) -end subroutine derzz_21 + end subroutine derzz_21 !******************************************************************** ! -subroutine derzz_22(tz,uz,x3dop,nx,ny,nz) + subroutine derzz_22(tz, uz, x3dop, nx, ny, nz) - implicit none + implicit none - integer, intent(in) :: nx, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop + integer, intent(in) :: nx, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop - call derzz_ij(tz,uz,x3dop%f,x3dop%s,x3dop%w,nx,ny,nz,x3dop%npaire,2,2) + call derzz_ij(tz, uz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz, x3dop%npaire, 2, 2) -end subroutine derzz_22 + end subroutine derzz_22 end module x3d_derive diff --git a/src/x3d_filters.f90 b/src/x3d_filters.f90 index 8252b1b..21439c3 100644 --- a/src/x3d_filters.f90 +++ b/src/x3d_filters.f90 @@ -4,49 +4,47 @@ module x3d_filters - use decomp_2d, only : mytype - use x3d_operator_1d, only : x3doperator1d - use param - use thomas - - implicit none - - ! Make everything public unless declared private - public - - ABSTRACT INTERFACE - SUBROUTINE FILTER_X(t,u,ff,fs,fw,nx,ny,nz,npaire) - use decomp_2d, only : mytype - integer, intent(in) :: nx,ny,nz,npaire - real(mytype), intent(out), dimension(nx,ny,nz) :: t - real(mytype), intent(in), dimension(nx,ny,nz) :: u - real(mytype), intent(in), dimension(nx):: ff,fs,fw - END SUBROUTINE FILTER_X - SUBROUTINE FILTER_Y(t,u,ff,fs,fw,nx,ny,nz,npaire) - use decomp_2d, only : mytype - integer, intent(in) :: nx,ny,nz,npaire - real(mytype), intent(out), dimension(nx,ny,nz) :: t - real(mytype), intent(in), dimension(nx,ny,nz) :: u - real(mytype), intent(in), dimension(ny):: ff,fs,fw - END SUBROUTINE FILTER_Y - SUBROUTINE FILTER_Z(t,u,ff,fs,fw,nx,ny,nz,npaire) - use decomp_2d, only : mytype - integer, intent(in) :: nx,ny,nz,npaire - real(mytype), intent(out), dimension(nx,ny,nz) :: t - real(mytype), intent(in), dimension(nx,ny,nz) :: u - real(mytype), intent(in), dimension(nz):: ff,fs,fw - END SUBROUTINE FILTER_Z - END INTERFACE - - PROCEDURE (FILTER_X) :: filx_00, filx_11, filx_12, filx_21, filx_22 - PROCEDURE (FILTER_Y) :: fily_00, fily_11, fily_12, fily_21, fily_22 - PROCEDURE (FILTER_Z) :: filz_00, filz_11, filz_12, filz_21, filz_22 - PROCEDURE (FILTER_X), POINTER :: filx=>null(), filxS=>null() - PROCEDURE (FILTER_Y), POINTER :: fily=>null(), filyS=>null() - PROCEDURE (FILTER_Z), POINTER :: filz=>null(), filzS=>null() + use decomp_2d, only: mytype + use x3d_operator_1d, only: x3doperator1d + use param + use thomas + + implicit none + + ! Make everything public unless declared private + public + + ABSTRACT INTERFACE + SUBROUTINE FILTER_X(t, u, ff, fs, fw, nx, ny, nz, npaire) + use decomp_2d, only: mytype + integer, intent(in) :: nx, ny, nz, npaire + real(mytype), intent(out), dimension(nx, ny, nz) :: t + real(mytype), intent(in), dimension(nx, ny, nz) :: u + real(mytype), intent(in), dimension(nx):: ff, fs, fw + END SUBROUTINE FILTER_X + SUBROUTINE FILTER_Y(t, u, ff, fs, fw, nx, ny, nz, npaire) + use decomp_2d, only: mytype + integer, intent(in) :: nx, ny, nz, npaire + real(mytype), intent(out), dimension(nx, ny, nz) :: t + real(mytype), intent(in), dimension(nx, ny, nz) :: u + real(mytype), intent(in), dimension(ny):: ff, fs, fw + END SUBROUTINE FILTER_Y + SUBROUTINE FILTER_Z(t, u, ff, fs, fw, nx, ny, nz, npaire) + use decomp_2d, only: mytype + integer, intent(in) :: nx, ny, nz, npaire + real(mytype), intent(out), dimension(nx, ny, nz) :: t + real(mytype), intent(in), dimension(nx, ny, nz) :: u + real(mytype), intent(in), dimension(nz):: ff, fs, fw + END SUBROUTINE FILTER_Z + END INTERFACE + + PROCEDURE(FILTER_X) :: filx_00, filx_11, filx_12, filx_21, filx_22 + PROCEDURE(FILTER_Y) :: fily_00, fily_11, fily_12, fily_21, fily_22 + PROCEDURE(FILTER_Z) :: filz_00, filz_11, filz_12, filz_21, filz_22 + PROCEDURE(FILTER_X), POINTER :: filx => null(), filxS => null() + PROCEDURE(FILTER_Y), POINTER :: fily => null(), filyS => null() + PROCEDURE(FILTER_Z), POINTER :: filz => null(), filzS => null() contains - - end module x3d_filters diff --git a/src/x3d_operator_1d.f90 b/src/x3d_operator_1d.f90 index e006fd2..9fac4bb 100644 --- a/src/x3d_operator_1d.f90 +++ b/src/x3d_operator_1d.f90 @@ -4,83 +4,82 @@ module x3d_operator_1d - use decomp_2d, only: mytype, nrank + use decomp_2d, only: mytype, nrank - implicit none + implicit none - type, public :: x3doperator1d - ! Size - integer :: n = 0 - ! Odd or even - integer :: npaire - ! Extra-diag coefficient - real(mytype) :: alfa - ! Arrays needed by the Thomas solver - ! See subroutine prepare(b,c,f,s,w,n) in schemes.f90 - real(mytype), dimension(:), pointer :: f=>null(), s=>null(), w=>null() - ! Array needed by the optimized Thomas solver - real(mytype), dimension(:), allocatable :: periodic + type, public :: x3doperator1d + ! Size + integer :: n = 0 + ! Odd or even + integer :: npaire + ! Extra-diag coefficient + real(mytype) :: alfa + ! Arrays needed by the Thomas solver + ! See subroutine prepare(b,c,f,s,w,n) in schemes.f90 + real(mytype), dimension(:), pointer :: f => null(), s => null(), w => null() + ! Array needed by the optimized Thomas solver + real(mytype), dimension(:), allocatable :: periodic - contains + contains procedure, public :: init procedure, public :: finalize - end type x3doperator1d + end type x3doperator1d - ! First derivative on the velocity grid - type(x3doperator1d), save, public :: x3d_op_derx, x3d_op_derxp - type(x3doperator1d), save, public :: x3d_op_dery, x3d_op_deryp - type(x3doperator1d), save, public :: x3d_op_derz, x3d_op_derzp - ! First derivative for scalars - type(x3doperator1d), save, public :: x3d_op_derxS, x3d_op_derxpS - type(x3doperator1d), save, public :: x3d_op_deryS, x3d_op_derypS - type(x3doperator1d), save, public :: x3d_op_derzS, x3d_op_derzpS + ! First derivative on the velocity grid + type(x3doperator1d), save, public :: x3d_op_derx, x3d_op_derxp + type(x3doperator1d), save, public :: x3d_op_dery, x3d_op_deryp + type(x3doperator1d), save, public :: x3d_op_derz, x3d_op_derzp + ! First derivative for scalars + type(x3doperator1d), save, public :: x3d_op_derxS, x3d_op_derxpS + type(x3doperator1d), save, public :: x3d_op_deryS, x3d_op_derypS + type(x3doperator1d), save, public :: x3d_op_derzS, x3d_op_derzpS - ! First derivative from velocity grid => pressure grid - type(x3doperator1d), save, public :: x3d_op_derxvp, x3d_op_deryvp, x3d_op_derzvp + ! First derivative from velocity grid => pressure grid + type(x3doperator1d), save, public :: x3d_op_derxvp, x3d_op_deryvp, x3d_op_derzvp - ! First derivative from pressure grid => velocity grid - type(x3doperator1d), save, public :: x3d_op_derxpv, x3d_op_derypv, x3d_op_derzpv + ! First derivative from pressure grid => velocity grid + type(x3doperator1d), save, public :: x3d_op_derxpv, x3d_op_derypv, x3d_op_derzpv - ! Interpolation from velocity grid => pressure grid - type(x3doperator1d), save, public :: x3d_op_intxvp, x3d_op_intyvp, x3d_op_intzvp + ! Interpolation from velocity grid => pressure grid + type(x3doperator1d), save, public :: x3d_op_intxvp, x3d_op_intyvp, x3d_op_intzvp - ! Interpolation from pressure grid => velocity grid - type(x3doperator1d), save, public :: x3d_op_intxpv, x3d_op_intypv, x3d_op_intzpv + ! Interpolation from pressure grid => velocity grid + type(x3doperator1d), save, public :: x3d_op_intxpv, x3d_op_intypv, x3d_op_intzpv - ! Second derivative on the velocity grid - type(x3doperator1d), save, public :: x3d_op_derxx, x3d_op_derxxp - type(x3doperator1d), save, public :: x3d_op_deryy, x3d_op_deryyp - type(x3doperator1d), save, public :: x3d_op_derzz, x3d_op_derzzp - ! Derivative for scalars - type(x3doperator1d), save, public :: x3d_op_derxxS, x3d_op_derxxpS - type(x3doperator1d), save, public :: x3d_op_deryyS, x3d_op_deryypS - type(x3doperator1d), save, public :: x3d_op_derzzS, x3d_op_derzzpS - - ! Make everything private unless declared public - private - public :: x3d_operator_1d_init, x3d_operator_1d_finalize + ! Second derivative on the velocity grid + type(x3doperator1d), save, public :: x3d_op_derxx, x3d_op_derxxp + type(x3doperator1d), save, public :: x3d_op_deryy, x3d_op_deryyp + type(x3doperator1d), save, public :: x3d_op_derzz, x3d_op_derzzp + ! Derivative for scalars + type(x3doperator1d), save, public :: x3d_op_derxxS, x3d_op_derxxpS + type(x3doperator1d), save, public :: x3d_op_deryyS, x3d_op_deryypS + type(x3doperator1d), save, public :: x3d_op_derzzS, x3d_op_derzzpS + ! Make everything private unless declared public + private + public :: x3d_operator_1d_init, x3d_operator_1d_finalize contains - ! - ! Associate pointers and pre-compute some arrays for periodic cases - ! - subroutine x3d_operator_1d_init() - - use variables - use param, only : nclx, ncly, nclz - use x3d_operator_x_data - use x3d_operator_y_data - use x3d_operator_z_data - use param, only: dx, dx2, nclx, nclx1, nclxn, nclxS1, nclxSn, & - dy, dy2, ncly, ncly1, nclyn, nclyS1, nclySn, & - dz, dz2, nclz, nclz1, nclzn, nclzS1, nclzSn, & - iscalar + ! + ! Associate pointers and pre-compute some arrays for periodic cases + ! + subroutine x3d_operator_1d_init() + + use variables + use param, only: nclx, ncly, nclz + use x3d_operator_x_data + use x3d_operator_y_data + use x3d_operator_z_data + use param, only: dx, dx2, nclx, nclx1, nclxn, nclxS1, nclxSn, & + dy, dy2, ncly, ncly1, nclyn, nclyS1, nclySn, & + dz, dz2, nclz, nclz1, nclzn, nclzS1, nclzSn, & + iscalar - implicit none + implicit none #ifdef DEBUG if (nrank == 0) write (*, *) '# x3d_operator_1d_init start' @@ -104,21 +103,21 @@ subroutine x3d_operator_1d_init() call first_deriv_imp_(alfa1z, af1z, bf1z, cf1z, df1z, alfa2z, af2z, alfanz, afnz, bfnz, & cfnz, dfnz, alfamz, afmz, alfakz, afkz, bfkz, & ffz, fsz, fwz, ffzp, fszp, fwzp, dz, nz, nclz1, nclzn) - endif + end if ! Scalars - if (iscalar.ne.0) then - call first_deriv_imp_(alfa1x, af1x, bf1x, cf1x, df1x, alfa2x, af2x, alfanx, afnx, bfnx, & - cfnx, dfnx, alfamx, afmx, alfaix, afix, bfix, & - ffxS, fsxS, fwxS, ffxpS, fsxpS, fwxpS, dx, nx, nclxS1, nclxSn) - call first_deriv_imp_(alfa1y, af1y, bf1y, cf1y, df1y, alfa2y, af2y, alfany, afny, bfny, & - cfny, dfny, alfamy, afmy, alfajy, afjy, bfjy, & - ffyS, fsyS, fwyS, ffypS, fsypS, fwypS, dy, ny, nclyS1, nclySn) - if (nz /= 1) then - call first_deriv_imp_(alfa1z, af1z, bf1z, cf1z, df1z, alfa2z, af2z, alfanz, afnz, bfnz, & - cfnz, dfnz, alfamz, afmz, alfakz, afkz, bfkz, & - ffzS, fszS, fwzS, ffzpS, fszpS, fwzpS, dz, nz, nclzS1, nclzSn) - endif - endif + if (iscalar /= 0) then + call first_deriv_imp_(alfa1x, af1x, bf1x, cf1x, df1x, alfa2x, af2x, alfanx, afnx, bfnx, & + cfnx, dfnx, alfamx, afmx, alfaix, afix, bfix, & + ffxS, fsxS, fwxS, ffxpS, fsxpS, fwxpS, dx, nx, nclxS1, nclxSn) + call first_deriv_imp_(alfa1y, af1y, bf1y, cf1y, df1y, alfa2y, af2y, alfany, afny, bfny, & + cfny, dfny, alfamy, afmy, alfajy, afjy, bfjy, & + ffyS, fsyS, fwyS, ffypS, fsypS, fwypS, dy, ny, nclyS1, nclySn) + if (nz /= 1) then + call first_deriv_imp_(alfa1z, af1z, bf1z, cf1z, df1z, alfa2z, af2z, alfanz, afnz, bfnz, & + cfnz, dfnz, alfamz, afmz, alfakz, afkz, bfkz, & + ffzS, fszS, fwzS, ffzpS, fszpS, fwzpS, dz, nz, nclzS1, nclzSn) + end if + end if ! Second derivative ! Velocity @@ -162,34 +161,33 @@ subroutine x3d_operator_1d_init() alsattz, asttz, bsttz, csttz, & alsakz, askz, bskz, cskz, dskz, & sfz, ssz, swz, sfzp, sszp, swzp, dz2, nz, nclz1, nclzn) - endif + end if ! Scalars - if (iscalar.ne.0) then - call second_deriv_imp_(alsa1x, as1x, bs1x, & - cs1x, ds1x, alsa2x, as2x, alsanx, asnx, bsnx, csnx, dsnx, alsamx, & - asmx, alsa3x, as3x, bs3x, alsatx, astx, bstx, & - alsa4x, as4x, bs4x, cs4x, & - alsattx, asttx, bsttx, csttx, & - alsaix, asix, bsix, csix, dsix, & - sfxS, ssxS, swxS, sfxpS, ssxpS, swxpS, dx2, nx, nclxS1, nclxSn) - call second_deriv_imp_(alsa1y, as1y, bs1y, & - cs1y, ds1y, alsa2y, as2y, alsany, asny, bsny, csny, dsny, alsamy, & - asmy, alsa3y, as3y, bs3y, alsaty, asty, bsty, & - alsa4y, as4y, bs4y, cs4y, & - alsatty, astty, bstty, cstty, & - alsajy, asjy, bsjy, csjy, dsjy, & - sfyS, ssyS, swyS, sfypS, ssypS, swypS, dy2, ny, nclyS1, nclySn) - if (nz /= 1) then - call second_deriv_imp_(alsa1z, as1z, bs1z, & - cs1z, ds1z, alsa2z, as2z, alsanz, asnz, bsnz, csnz, dsnz, alsamz, & - asmz, alsa3z, as3z, bs3z, alsatz, astz, bstz, & - alsa4z, as4z, bs4z, cs4z, & - alsattz, asttz, bsttz, csttz, & - alsakz, askz, bskz, cskz, dskz, & - sfzS, sszS, swzS, sfzpS, sszpS, swzpS, dz2, nz, nclzS1, nclzSn) - endif - endif - + if (iscalar /= 0) then + call second_deriv_imp_(alsa1x, as1x, bs1x, & + cs1x, ds1x, alsa2x, as2x, alsanx, asnx, bsnx, csnx, dsnx, alsamx, & + asmx, alsa3x, as3x, bs3x, alsatx, astx, bstx, & + alsa4x, as4x, bs4x, cs4x, & + alsattx, asttx, bsttx, csttx, & + alsaix, asix, bsix, csix, dsix, & + sfxS, ssxS, swxS, sfxpS, ssxpS, swxpS, dx2, nx, nclxS1, nclxSn) + call second_deriv_imp_(alsa1y, as1y, bs1y, & + cs1y, ds1y, alsa2y, as2y, alsany, asny, bsny, csny, dsny, alsamy, & + asmy, alsa3y, as3y, bs3y, alsaty, asty, bsty, & + alsa4y, as4y, bs4y, cs4y, & + alsatty, astty, bstty, cstty, & + alsajy, asjy, bsjy, csjy, dsjy, & + sfyS, ssyS, swyS, sfypS, ssypS, swypS, dy2, ny, nclyS1, nclySn) + if (nz /= 1) then + call second_deriv_imp_(alsa1z, as1z, bs1z, & + cs1z, ds1z, alsa2z, as2z, alsanz, asnz, bsnz, csnz, dsnz, alsamz, & + asmz, alsa3z, as3z, bs3z, alsatz, astz, bstz, & + alsa4z, as4z, bs4z, cs4z, & + alsattz, asttz, bsttz, csttz, & + alsakz, askz, bskz, cskz, dskz, & + sfzS, sszS, swzS, sfzpS, sszpS, swzpS, dz2, nz, nclzS1, nclzSn) + end if + end if call interpol_exp_(dx, nxm, nx, nclx1, nclxn, & alcaix6, acix6, bcix6, & @@ -228,215 +226,215 @@ subroutine x3d_operator_1d_init() cfi6z, cci6z, cbi6z, cfip6z, csip6z, cwip6z, csi6z, & cwi6z, cifi6z, cici6z, cibi6z, cifip6z, & cisip6z, ciwip6z, cisi6z, ciwi6z) - endif - - ! derx operators for the velocity and scalars - call init(x3d_op_derx, ffx, fsx, fwx, nx, nclx, alfaix, 0) - call init(x3d_op_derxp, ffxp, fsxp, fwxp, nx, nclx, alfaix, 1) - if (iscalar.ne.0) then - call init(x3d_op_derxS, ffxS, fsxS, fwxS, nx, nclx, alfaix, 0) - call init(x3d_op_derxpS, ffxpS, fsxpS, fwxpS, nx, nclx, alfaix, 1) - endif - - ! dery operators for the velocity and scalars - call init(x3d_op_dery, ffy, fsy, fwy, ny, ncly, alfajy, 0) - call init(x3d_op_deryp, ffyp, fsyp, fwyp, ny, ncly, alfajy, 1) - if (iscalar.ne.0) then - call init(x3d_op_deryS, ffyS, fsyS, fwyS, ny, ncly, alfajy, 0) - call init(x3d_op_derypS, ffypS, fsypS, fwypS, ny, ncly, alfajy, 1) - endif - - ! derz operators for the velocity and scalars - call init(x3d_op_derz, ffz, fsz, fwz, nz, nclz, alfakz, 0) - call init(x3d_op_derzp, ffzp, fszp, fwzp, nz, nclz, alfakz, 1) - if (iscalar.ne.0) then - call init(x3d_op_derzS, ffzS, fszS, fwzS, nz, nclz, alfakz, 0) - call init(x3d_op_derzpS, ffzpS, fszpS, fwzpS, nz, nclz, alfakz, 1) - endif - - ! Staggered derivative velocity => pressure - call init(x3d_op_derxvp, cfx6, csx6, cwx6, nxm, nclx, alcaix6, 1) - call init(x3d_op_deryvp, cfy6, csy6, cwy6, nym, ncly, alcaiy6, 1) - call init(x3d_op_derzvp, cfz6, csz6, cwz6, nzm, nclz, alcaiz6, 1) - - ! Staggered derivative pressure => velocity - if (nclx) then - call init(x3d_op_derxpv, cfx6, csx6, cwx6, nx, nclx, alcaix6, 0) - else - call init(x3d_op_derxpv, cfip6, csip6, cwip6, nx, nclx, alcaix6, 0) - endif - if (ncly) then - call init(x3d_op_derypv, cfy6, csy6, cwy6, ny, ncly, alcaiy6, 0) - else - call init(x3d_op_derypv, cfip6y, csip6y, cwip6y, ny, ncly, alcaiy6, 0) - endif - if (nclz) then - call init(x3d_op_derzpv, cfz6, csz6, cwz6, nz, nclz, alcaiz6, 0) - else - call init(x3d_op_derzpv, cfip6z, csip6z, cwip6z, nz, nclz, alcaiz6, 0) - endif - - ! Interpolation velocity => pressure - call init(x3d_op_intxvp, cifxp6, cisxp6, ciwxp6, nxm, nclx, ailcaix6, 1) - call init(x3d_op_intyvp, cifyp6, cisyp6, ciwyp6, nym, ncly, ailcaiy6, 1) - call init(x3d_op_intzvp, cifzp6, ciszp6, ciwzp6, nzm, nclz, ailcaiz6, 1) - - ! Interpolation pressure => velocity - if (nclx) then - call init(x3d_op_intxpv, cifx6, cisx6, ciwx6, nx, nclx, ailcaix6, 1) - else - call init(x3d_op_intxpv, cifip6, cisip6, ciwip6, nx, nclx, ailcaix6, 1) - endif - if (ncly) then - call init(x3d_op_intypv, cify6, cisy6, ciwy6, ny, ncly, ailcaiy6, 1) - else - call init(x3d_op_intypv, cifip6y, cisip6y, ciwip6y, ny, ncly, ailcaiy6, 1) - endif - if (nclz) then - call init(x3d_op_intzpv, cifz6, cisz6, ciwz6, nz, nclz, ailcaiz6, 1) - else - call init(x3d_op_intzpv, cifip6z, cisip6z, ciwip6z, nz, nclz, ailcaiz6, 1) - endif - - ! Second derivative on the velocity grid - call init(x3d_op_derxx, sfx, ssx, swx, nx, nclx, alsaix, 0) - call init(x3d_op_derxxp, sfxp, ssxp, swxp, nx, nclx, alsaix, 1) - call init(x3d_op_deryy, sfy, ssy, swy, ny, ncly, alsajy, 0) - call init(x3d_op_deryyp, sfyp, ssyp, swyp, ny, ncly, alsajy, 1) - call init(x3d_op_derzz, sfz, ssz, swz, nz, nclz, alsakz, 0) - call init(x3d_op_derzzp, sfzp, sszp, swzp, nz, nclz, alsakz, 1) - if (iscalar.ne.0) then - call init(x3d_op_derxxS, sfxS, ssxS, swxS, nx, nclx, alsaix, 0) - call init(x3d_op_derxxpS, sfxpS, ssxpS, swxpS, nx, nclx, alsaix, 1) - call init(x3d_op_deryyS, sfyS, ssyS, swyS, ny, ncly, alsajy, 0) - call init(x3d_op_deryypS, sfypS, ssypS, swypS, ny, ncly, alsajy, 1) - call init(x3d_op_derzzS, sfzS, sszS, swzS, nz, nclz, alsakz, 0) - call init(x3d_op_derzzpS, sfzpS, sszpS, swzpS, nz, nclz, alsakz, 1) - endif + end if + + ! derx operators for the velocity and scalars + call init(x3d_op_derx, ffx, fsx, fwx, nx, nclx, alfaix, 0) + call init(x3d_op_derxp, ffxp, fsxp, fwxp, nx, nclx, alfaix, 1) + if (iscalar /= 0) then + call init(x3d_op_derxS, ffxS, fsxS, fwxS, nx, nclx, alfaix, 0) + call init(x3d_op_derxpS, ffxpS, fsxpS, fwxpS, nx, nclx, alfaix, 1) + end if + + ! dery operators for the velocity and scalars + call init(x3d_op_dery, ffy, fsy, fwy, ny, ncly, alfajy, 0) + call init(x3d_op_deryp, ffyp, fsyp, fwyp, ny, ncly, alfajy, 1) + if (iscalar /= 0) then + call init(x3d_op_deryS, ffyS, fsyS, fwyS, ny, ncly, alfajy, 0) + call init(x3d_op_derypS, ffypS, fsypS, fwypS, ny, ncly, alfajy, 1) + end if + + ! derz operators for the velocity and scalars + call init(x3d_op_derz, ffz, fsz, fwz, nz, nclz, alfakz, 0) + call init(x3d_op_derzp, ffzp, fszp, fwzp, nz, nclz, alfakz, 1) + if (iscalar /= 0) then + call init(x3d_op_derzS, ffzS, fszS, fwzS, nz, nclz, alfakz, 0) + call init(x3d_op_derzpS, ffzpS, fszpS, fwzpS, nz, nclz, alfakz, 1) + end if + + ! Staggered derivative velocity => pressure + call init(x3d_op_derxvp, cfx6, csx6, cwx6, nxm, nclx, alcaix6, 1) + call init(x3d_op_deryvp, cfy6, csy6, cwy6, nym, ncly, alcaiy6, 1) + call init(x3d_op_derzvp, cfz6, csz6, cwz6, nzm, nclz, alcaiz6, 1) + + ! Staggered derivative pressure => velocity + if (nclx) then + call init(x3d_op_derxpv, cfx6, csx6, cwx6, nx, nclx, alcaix6, 0) + else + call init(x3d_op_derxpv, cfip6, csip6, cwip6, nx, nclx, alcaix6, 0) + end if + if (ncly) then + call init(x3d_op_derypv, cfy6, csy6, cwy6, ny, ncly, alcaiy6, 0) + else + call init(x3d_op_derypv, cfip6y, csip6y, cwip6y, ny, ncly, alcaiy6, 0) + end if + if (nclz) then + call init(x3d_op_derzpv, cfz6, csz6, cwz6, nz, nclz, alcaiz6, 0) + else + call init(x3d_op_derzpv, cfip6z, csip6z, cwip6z, nz, nclz, alcaiz6, 0) + end if + + ! Interpolation velocity => pressure + call init(x3d_op_intxvp, cifxp6, cisxp6, ciwxp6, nxm, nclx, ailcaix6, 1) + call init(x3d_op_intyvp, cifyp6, cisyp6, ciwyp6, nym, ncly, ailcaiy6, 1) + call init(x3d_op_intzvp, cifzp6, ciszp6, ciwzp6, nzm, nclz, ailcaiz6, 1) + + ! Interpolation pressure => velocity + if (nclx) then + call init(x3d_op_intxpv, cifx6, cisx6, ciwx6, nx, nclx, ailcaix6, 1) + else + call init(x3d_op_intxpv, cifip6, cisip6, ciwip6, nx, nclx, ailcaix6, 1) + end if + if (ncly) then + call init(x3d_op_intypv, cify6, cisy6, ciwy6, ny, ncly, ailcaiy6, 1) + else + call init(x3d_op_intypv, cifip6y, cisip6y, ciwip6y, ny, ncly, ailcaiy6, 1) + end if + if (nclz) then + call init(x3d_op_intzpv, cifz6, cisz6, ciwz6, nz, nclz, ailcaiz6, 1) + else + call init(x3d_op_intzpv, cifip6z, cisip6z, ciwip6z, nz, nclz, ailcaiz6, 1) + end if + + ! Second derivative on the velocity grid + call init(x3d_op_derxx, sfx, ssx, swx, nx, nclx, alsaix, 0) + call init(x3d_op_derxxp, sfxp, ssxp, swxp, nx, nclx, alsaix, 1) + call init(x3d_op_deryy, sfy, ssy, swy, ny, ncly, alsajy, 0) + call init(x3d_op_deryyp, sfyp, ssyp, swyp, ny, ncly, alsajy, 1) + call init(x3d_op_derzz, sfz, ssz, swz, nz, nclz, alsakz, 0) + call init(x3d_op_derzzp, sfzp, sszp, swzp, nz, nclz, alsakz, 1) + if (iscalar /= 0) then + call init(x3d_op_derxxS, sfxS, ssxS, swxS, nx, nclx, alsaix, 0) + call init(x3d_op_derxxpS, sfxpS, ssxpS, swxpS, nx, nclx, alsaix, 1) + call init(x3d_op_deryyS, sfyS, ssyS, swyS, ny, ncly, alsajy, 0) + call init(x3d_op_deryypS, sfypS, ssypS, swypS, ny, ncly, alsajy, 1) + call init(x3d_op_derzzS, sfzS, sszS, swzS, nz, nclz, alsakz, 0) + call init(x3d_op_derzzpS, sfzpS, sszpS, swzpS, nz, nclz, alsakz, 1) + end if #ifdef DEBUG if (nrank == 0) write (*, *) '# x3d_operator_1d_init done' #endif - end subroutine x3d_operator_1d_init - - ! - ! Nullify pointers and free allocated memory - ! - subroutine x3d_operator_1d_finalize() - - use param, only : iscalar - - implicit none - - call finalize(x3d_op_derx) - call finalize(x3d_op_derxp) - if (iscalar.ne.0) then - call finalize(x3d_op_derxS) - call finalize(x3d_op_derxpS) - endif - - call finalize(x3d_op_dery) - call finalize(x3d_op_deryp) - if (iscalar.ne.0) then - call finalize(x3d_op_deryS) - call finalize(x3d_op_derypS) - endif - - call finalize(x3d_op_derz) - call finalize(x3d_op_derzp) - if (iscalar.ne.0) then - call finalize(x3d_op_derzS) - call finalize(x3d_op_derzpS) - endif - - call finalize(x3d_op_derxvp) - call finalize(x3d_op_deryvp) - call finalize(x3d_op_derzvp) - - call finalize(x3d_op_derxpv) - call finalize(x3d_op_derypv) - call finalize(x3d_op_derzpv) - - call finalize(x3d_op_intxvp) - call finalize(x3d_op_intyvp) - call finalize(x3d_op_intzvp) - - call finalize(x3d_op_intxpv) - call finalize(x3d_op_intypv) - call finalize(x3d_op_intzpv) - - call finalize(x3d_op_derxx) - call finalize(x3d_op_derxxp) - call finalize(x3d_op_deryy) - call finalize(x3d_op_deryyp) - call finalize(x3d_op_derzz) - call finalize(x3d_op_derzzp) - if (iscalar.ne.0) then - call finalize(x3d_op_derxxS) - call finalize(x3d_op_derxxpS) - call finalize(x3d_op_deryyS) - call finalize(x3d_op_deryypS) - call finalize(x3d_op_derzzS) - call finalize(x3d_op_derzzpS) - endif - - end subroutine x3d_operator_1d_finalize - - ! - ! Associate pointers with the given targets - ! - subroutine init(x3dop, f, s, w, n, ncl, alfa, paire) - - use param, only : zero, one - use thomas, only : thomas1d - - implicit none - - ! Arguments - class(x3doperator1d) :: x3dop - real(mytype), dimension(:), target, intent(in) :: f, s, w - integer, intent(in) :: n, paire - logical, intent(in) :: ncl - real(mytype), intent(in) :: alfa - - ! Local variable - integer :: i - - ! Nothing to do when n=1 (nz=1 for instance) - if (n==1) return - - x3dop%n = n - x3dop%npaire = paire - x3dop%f => f - x3dop%s => s - x3dop%w => w - x3dop%alfa = alfa - if (ncl) then - allocate(x3dop%periodic(n)) - x3dop%periodic = (/-one, (zero, i=2, n-1), alfa/) - call thomas1d(x3dop%periodic, f, s, w, n) - endif - - end subroutine init - - ! - ! Nullify pointer and free allocated memory of the given operator - ! - subroutine finalize(x3dop) - - implicit none - - class(x3doperator1d) :: x3dop - - x3dop%n = 0 - x3dop%npaire = 0 - nullify(x3dop%f) - nullify(x3dop%s) - nullify(x3dop%w) - if (allocated(x3dop%periodic)) deallocate(x3dop%periodic) - - end subroutine finalize + end subroutine x3d_operator_1d_init + + ! + ! Nullify pointers and free allocated memory + ! + subroutine x3d_operator_1d_finalize() + + use param, only: iscalar + + implicit none + + call finalize(x3d_op_derx) + call finalize(x3d_op_derxp) + if (iscalar /= 0) then + call finalize(x3d_op_derxS) + call finalize(x3d_op_derxpS) + end if + + call finalize(x3d_op_dery) + call finalize(x3d_op_deryp) + if (iscalar /= 0) then + call finalize(x3d_op_deryS) + call finalize(x3d_op_derypS) + end if + + call finalize(x3d_op_derz) + call finalize(x3d_op_derzp) + if (iscalar /= 0) then + call finalize(x3d_op_derzS) + call finalize(x3d_op_derzpS) + end if + + call finalize(x3d_op_derxvp) + call finalize(x3d_op_deryvp) + call finalize(x3d_op_derzvp) + + call finalize(x3d_op_derxpv) + call finalize(x3d_op_derypv) + call finalize(x3d_op_derzpv) + + call finalize(x3d_op_intxvp) + call finalize(x3d_op_intyvp) + call finalize(x3d_op_intzvp) + + call finalize(x3d_op_intxpv) + call finalize(x3d_op_intypv) + call finalize(x3d_op_intzpv) + + call finalize(x3d_op_derxx) + call finalize(x3d_op_derxxp) + call finalize(x3d_op_deryy) + call finalize(x3d_op_deryyp) + call finalize(x3d_op_derzz) + call finalize(x3d_op_derzzp) + if (iscalar /= 0) then + call finalize(x3d_op_derxxS) + call finalize(x3d_op_derxxpS) + call finalize(x3d_op_deryyS) + call finalize(x3d_op_deryypS) + call finalize(x3d_op_derzzS) + call finalize(x3d_op_derzzpS) + end if + + end subroutine x3d_operator_1d_finalize + + ! + ! Associate pointers with the given targets + ! + subroutine init(x3dop, f, s, w, n, ncl, alfa, paire) + + use param, only: zero, one + use thomas, only: thomas1d + + implicit none + + ! Arguments + class(x3doperator1d) :: x3dop + real(mytype), dimension(:), target, intent(in) :: f, s, w + integer, intent(in) :: n, paire + logical, intent(in) :: ncl + real(mytype), intent(in) :: alfa + + ! Local variable + integer :: i + + ! Nothing to do when n=1 (nz=1 for instance) + if (n == 1) return + + x3dop%n = n + x3dop%npaire = paire + x3dop%f => f + x3dop%s => s + x3dop%w => w + x3dop%alfa = alfa + if (ncl) then + allocate (x3dop%periodic(n)) + x3dop%periodic = (/-one, (zero, i=2, n - 1), alfa/) + call thomas1d(x3dop%periodic, f, s, w, n) + end if + + end subroutine init + + ! + ! Nullify pointer and free allocated memory of the given operator + ! + subroutine finalize(x3dop) + + implicit none + + class(x3doperator1d) :: x3dop + + x3dop%n = 0 + x3dop%npaire = 0 + nullify (x3dop%f) + nullify (x3dop%s) + nullify (x3dop%w) + if (allocated(x3dop%periodic)) deallocate (x3dop%periodic) + + end subroutine finalize ! ! Prepare Thomas algorithm for a tri-diagonal matrix M @@ -499,17 +497,17 @@ subroutine first_deriv_exp_(alfa1, af1, bf1, cf1, df1, alfa2, af2, alfan, afn, b bfi = zero elseif (ifirstder == 2) then ! Fourth-order central call decomp_2d_abort(__FILE__, __LINE__, ifirstder, & - "Set of coefficients not ready yet") + "Set of coefficients not ready yet") elseif (ifirstder == 3) then ! Fourth-order compact call decomp_2d_abort(__FILE__, __LINE__, ifirstder, & - "Set of coefficients not ready yet") + "Set of coefficients not ready yet") elseif (ifirstder == 4) then ! Sixth-order compact alfai = one/three afi = (seven/nine)/d bfi = (one/36._mytype)/d else call decomp_2d_abort(__FILE__, __LINE__, & - ifirstder, "This is not an option. Please use ifirstder=1,2,3,4") + ifirstder, "This is not an option. Please use ifirstder=1,2,3,4") end if if (ifirstder == 1) then @@ -560,28 +558,28 @@ subroutine first_deriv_imp_(alfa1, af1, bf1, cf1, df1, alfa2, af2, alfan, afn, b integer, intent(in) :: n, ncl1, ncln real(mytype), dimension(n), intent(out) :: ff, fs, fw, ffp, fsp, fwp real(mytype), intent(in) :: alfa1, af1, bf1, cf1, df1, alfa2, af2, alfan, afn, bfn, & - cfn, dfn, alfam, afm, alfai, afi, bfi + cfn, dfn, alfam, afm, alfai, afi, bfi integer :: i real(mytype), dimension(n) :: fb, fc ff = zero; fs = zero; fw = zero; ffp = zero; fsp = zero; fwp = zero fb = zero; fc = zero - if (ncl1 .eq. 0) then !Periodic + if (ncl1 == 0) then !Periodic ff(1) = alfai ff(2) = alfai fc(1) = two fc(2) = one fb(1) = alfai fb(2) = alfai - elseif (ncl1 .eq. 1) then !Free-slip + elseif (ncl1 == 1) then !Free-slip ff(1) = alfai + alfai ff(2) = alfai fc(1) = one fc(2) = one fb(1) = alfai fb(2) = alfai - elseif (ncl1 .eq. 2) then !Dirichlet + elseif (ncl1 == 2) then !Dirichlet ff(1) = alfa1 ff(2) = alfa2 fc(1) = one @@ -589,7 +587,7 @@ subroutine first_deriv_imp_(alfa1, af1, bf1, cf1, df1, alfa2, af2, alfan, afn, b fb(1) = alfa2 fb(2) = alfai end if - if (ncln .eq. 0) then !Periodic + if (ncln == 0) then !Periodic ff(n - 2) = alfai ff(n - 1) = alfai ff(n) = zero @@ -599,7 +597,7 @@ subroutine first_deriv_imp_(alfa1, af1, bf1, cf1, df1, alfa2, af2, alfan, afn, b fb(n - 2) = alfai fb(n - 1) = alfai fb(n) = zero - elseif (ncln .eq. 1) then !Free-slip + elseif (ncln == 1) then !Free-slip ff(n - 2) = alfai ff(n - 1) = alfai ff(n) = zero @@ -609,7 +607,7 @@ subroutine first_deriv_imp_(alfa1, af1, bf1, cf1, df1, alfa2, af2, alfan, afn, b fb(n - 2) = alfai fb(n - 1) = alfai + alfai fb(n) = zero - elseif (ncln .eq. 2) then !Dirichlet + elseif (ncln == 2) then !Dirichlet ff(n - 2) = alfai ff(n - 1) = alfam ff(n) = zero @@ -632,10 +630,10 @@ subroutine first_deriv_imp_(alfa1, af1, bf1, cf1, df1, alfa2, af2, alfan, afn, b call prepare(fb, fc, ff, fs, fw, n) - if (ncl1 .eq. 1) then + if (ncl1 == 1) then ffp(1) = zero end if - if (ncln .eq. 1) then + if (ncln == 1) then fb(n - 1) = zero end if @@ -687,10 +685,10 @@ subroutine second_deriv_exp_(alsa1, as1, bs1, & cstt = csi elseif (isecondder == 2) then ! Fourth-order central call decomp_2d_abort(__FILE__, __LINE__, & - isecondder, "Set of coefficients not ready yet") + isecondder, "Set of coefficients not ready yet") elseif (isecondder == 3) then ! Fourth-order compact call decomp_2d_abort(__FILE__, __LINE__, & - isecondder, "Set of coefficients not ready yet") + isecondder, "Set of coefficients not ready yet") elseif (isecondder == 4) then ! Sixth-order compact Lele style (no extra dissipation) alsai = two/11._mytype asi = (12._mytype/11._mytype)/d2 @@ -793,17 +791,17 @@ subroutine second_deriv_imp_(alsa1, as1, bs1, & integer, intent(in) :: n, ncl1, ncln real(mytype), dimension(n), intent(out) :: sf, ss, sw, sfp, ssp, swp real(mytype), intent(in) :: alsa1, as1, bs1, & - cs1, ds1, alsa2, as2, alsan, asn, bsn, csn, dsn, alsam, & - asm, alsa3, as3, bs3, alsat, ast, bst, & - alsa4, as4, bs4, cs4, & - alsatt, astt, bstt, cstt, & - alsai, asi, bsi, csi, dsi + cs1, ds1, alsa2, as2, alsan, asn, bsn, csn, dsn, alsam, & + asm, alsa3, as3, bs3, alsat, ast, bst, & + alsa4, as4, bs4, cs4, & + alsatt, astt, bstt, cstt, & + alsai, asi, bsi, csi, dsi integer :: i real(mytype), dimension(n) :: sb, sc sf = zero; ss = zero; sw = zero; sfp = zero; ssp = zero; swp = zero - if (ncl1 .eq. 0) then !Periodic + if (ncl1 == 0) then !Periodic sf(1) = alsai sf(2) = alsai sf(3) = alsai @@ -816,7 +814,7 @@ subroutine second_deriv_imp_(alsa1, as1, bs1, & sb(2) = alsai sb(3) = alsai sb(4) = alsai - elseif (ncl1 .eq. 1) then !Free-slip + elseif (ncl1 == 1) then !Free-slip sf(1) = alsai + alsai sf(2) = alsai sf(3) = alsai @@ -829,7 +827,7 @@ subroutine second_deriv_imp_(alsa1, as1, bs1, & sb(2) = alsai sb(3) = alsai sb(4) = alsai - elseif (ncl1 .eq. 2) then !Dirichlet + elseif (ncl1 == 2) then !Dirichlet sf(1) = alsa1 sf(2) = alsa2 sf(3) = alsa3 @@ -843,7 +841,7 @@ subroutine second_deriv_imp_(alsa1, as1, bs1, & sb(3) = alsa4 sb(4) = alsai end if - if (ncln .eq. 0) then !Periodic + if (ncln == 0) then !Periodic sf(n - 4) = alsai sf(n - 3) = alsai sf(n - 2) = alsai @@ -859,7 +857,7 @@ subroutine second_deriv_imp_(alsa1, as1, bs1, & sb(n - 2) = alsai sb(n - 1) = alsai sb(n) = zero - elseif (ncln .eq. 1) then !Free-slip + elseif (ncln == 1) then !Free-slip sf(n - 4) = alsai sf(n - 3) = alsai sf(n - 2) = alsai @@ -875,7 +873,7 @@ subroutine second_deriv_imp_(alsa1, as1, bs1, & sb(n - 2) = alsai sb(n - 1) = alsai + alsai sb(n) = zero - elseif (ncln .eq. 2) then !Dirichlet + elseif (ncln == 2) then !Dirichlet sf(n - 4) = alsai sf(n - 3) = alsatt sf(n - 2) = alsat @@ -902,14 +900,14 @@ subroutine second_deriv_imp_(alsa1, as1, bs1, & sfp(i) = sf(i) end do - if (ncl1 .eq. 1) then + if (ncl1 == 1) then sf(1) = zero end if call prepare(sb, sc, sf, ss, sw, n) call prepare(sb, sc, sfp, ssp, swp, n) - if (ncln .eq. 1) then + if (ncln == 1) then sb(n - 1) = zero call prepare(sb, sc, sf, ss, sw, n) end if @@ -948,13 +946,13 @@ subroutine interpol_exp_(dx, nxm, nx, nclx1, nclxn, & bicix6 = zero cicix6 = zero dicix6 = zero - else if (ipinter .eq. 1) then + else if (ipinter == 1) then ailcaix6 = three/ten aicix6 = three/four bicix6 = one/(two*ten) cicix6 = zero dicix6 = zero - else if (ipinter .eq. 2) then + else if (ipinter == 2) then ailcaix6 = 0.461658_mytype dicix6 = 0.00293016_mytype @@ -966,7 +964,7 @@ subroutine interpol_exp_(dx, nxm, nx, nclx1, nclxn, & bicix6 = bicix6/two cicix6 = cicix6/two dicix6 = dicix6/two - else if (ipinter .eq. 3) then + else if (ipinter == 3) then ailcaix6 = 0.49_mytype aicix6 = one/128._mytype*(75._mytype + 70._mytype*ailcaix6) bicix6 = one/256._mytype*(126._mytype*ailcaix6 - 25._mytype) @@ -1113,7 +1111,7 @@ subroutine interpol_imp_(dx, nxm, nx, nclx1, nclxn, & call prepare(cbi6, cci6, cfip6, csip6, cwip6, nx) call prepare(cibi6, cici6, cifi6, cisi6, ciwi6, nx) call prepare(cibi6, cici6, cifip6, cisip6, ciwip6, nx) - if (nclxn .eq. 1) then + if (nclxn == 1) then cbx6(nxm - 1) = zero cibx6(nxm) = zero cbi6(nx - 1) = zero @@ -1123,7 +1121,7 @@ subroutine interpol_imp_(dx, nxm, nx, nclx1, nclxn, & call prepare(cbi6, cci6, cfip6, csip6, cwip6, nx) call prepare(cibi6, cici6, cifip6, cisip6, ciwip6, nx) end if - if (nclxn .eq. 2) then + if (nclxn == 2) then cbx6(nxm - 1) = zero cibx6(nxm) = zero cbi6(nx - 1) = zero diff --git a/src/x3d_operator_z_data.f90 b/src/x3d_operator_z_data.f90 index 0fb02ca..4dda83b 100644 --- a/src/x3d_operator_z_data.f90 +++ b/src/x3d_operator_z_data.f90 @@ -60,7 +60,7 @@ subroutine x3d_operator_z_data_init(nz, nzm) integer, intent(in) :: nz, nzm - if (nz==1) return + if (nz == 1) return allocate (ffz(nz)) ffz = 0._mytype @@ -137,7 +137,7 @@ subroutine x3d_operator_z_data_finalize() implicit none - if (.not.allocated(ffz)) return + if (.not. allocated(ffz)) return deallocate (ffz) deallocate (sfz) diff --git a/src/x3d_precision.f90 b/src/x3d_precision.f90 index 12bd6e9..8e9f471 100644 --- a/src/x3d_precision.f90 +++ b/src/x3d_precision.f90 @@ -4,20 +4,20 @@ module x3d_precision - use, intrinsic :: iso_fortran_env, only : real32, real64 - use decomp_2d, only : mytype + use, intrinsic :: iso_fortran_env, only: real32, real64 + use decomp_2d, only: mytype - implicit none + implicit none #ifdef DOUBLE_PREC - real(mytype),parameter, public :: pi=dacos(-1._real64) - real(mytype),parameter, public :: twopi=2._real64*dacos(-1._real64) + real(mytype), parameter, public :: pi = dacos(-1._real64) + real(mytype), parameter, public :: twopi = 2._real64*dacos(-1._real64) #else - real(mytype),parameter, public :: pi=acos(-1._real32) - real(mytype),parameter, public :: twopi=2._real32*acos(-1._real32) + real(mytype), parameter, public :: pi = acos(-1._real32) + real(mytype), parameter, public :: twopi = 2._real32*acos(-1._real32) #endif - ! Make everything private unless declared public - private + ! Make everything private unless declared public + private end module x3d_precision diff --git a/src/x3d_staggered.f90 b/src/x3d_staggered.f90 index 07936cf..9e3da06 100644 --- a/src/x3d_staggered.f90 +++ b/src/x3d_staggered.f90 @@ -4,1314 +4,1312 @@ module x3d_staggered - use decomp_2d, only : mytype - use x3d_operator_1d, only : x3doperator1d - use param - use thomas + use decomp_2d, only: mytype + use x3d_operator_1d, only: x3doperator1d + use param + use thomas - implicit none - - ! Make everything public unless declared private - public + implicit none + ! Make everything public unless declared private + public contains - !******************************************************************** ! -subroutine derxvp(tx,ux,x3dop,nx,nxm,ny,nz) - - use x3d_operator_x_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, nxm, ny, nz - real(mytype), intent(out), dimension(nxm,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (nclx) then - ! nxm = nx - do concurrent (k=1:nz, j=1:ny) - - ! Compute r.h.s. - tx(1,j,k) = acix6*(ux(2,j,k)-ux(1 ,j,k)) & - + bcix6*(ux(3,j,k)-ux(nx,j,k)) - tx(2,j,k) = acix6*(ux(3,j,k)-ux(2,j,k)) & - + bcix6*(ux(4,j,k)-ux(1,j,k)) - do concurrent (i=3:nx-2) - tx(i,j,k) = acix6*(ux(i+1,j,k)-ux(i ,j,k)) & - + bcix6*(ux(i+2,j,k)-ux(i-1,j,k)) - enddo - tx(nx-1,j,k) = acix6*(ux(nx,j,k)-ux(nx-1,j,k)) & - + bcix6*(ux(1 ,j,k)-ux(nx-2,j,k)) - tx(nx ,j,k) = acix6*(ux(1,j,k)-ux(nx ,j,k)) & - + bcix6*(ux(2,j,k)-ux(nx-1,j,k)) - enddo - - ! Solve tri-diagonal system - call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nxm = nx-1 - do concurrent (k=1:nz, j=1:ny) - - ! Compute r.h.s. - if (x3dop%npaire==1) then - tx(1,j,k) = acix6*(ux(2,j,k)-ux(1,j,k)) & - + bcix6*(ux(3,j,k)-ux(2,j,k)) - tx(2,j,k) = acix6*(ux(3,j,k)-ux(2,j,k)) & - + bcix6*(ux(4,j,k)-ux(1,j,k)) - else - tx(1,j,k) = acix6*(ux(2,j,k)-ux(1,j,k)) & - + bcix6*(ux(3,j,k)-two*ux(1,j,k)+ux(2,j,k)) - tx(2,j,k) = acix6*(ux(3,j,k)-ux(2,j,k)) & - + bcix6*(ux(4,j,k)-ux(1,j,k)) - endif - do concurrent (i=3:nxm-2) - tx(i,j,k) = acix6*(ux(i+1,j,k)-ux(i ,j,k)) & - + bcix6*(ux(i+2,j,k)-ux(i-1,j,k)) - enddo - if (x3dop%npaire==1) then - tx(nxm-1,j,k) = acix6*(ux(nxm,j,k)-ux(nxm-1,j,k)) & - + bcix6*(ux(nx ,j,k)-ux(nxm-2,j,k)) - tx(nxm,j,k) = acix6*(ux(nx ,j,k)-ux(nxm ,j,k)) & - + bcix6*(ux(nxm,j,k)-ux(nxm-1,j,k)) - else - tx(nxm-1,j,k) = acix6*(ux(nxm,j,k)-ux(nxm-1,j,k)) & - + bcix6*(ux(nx ,j,k)-ux(nxm-2,j,k)) - tx(nxm,j,k) = acix6*(ux(nx,j,k)-ux(nxm,j,k)) & - + bcix6*(two*ux(nx,j,k)-ux(nxm,j,k)-ux(nxm-1,j,k)) - endif - enddo - - ! Solve tri-diagonal system - call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, nxm, ny, nz) - - endif - -end subroutine derxvp + subroutine derxvp(tx, ux, x3dop, nx, nxm, ny, nz) + + use x3d_operator_x_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, nxm, ny, nz + real(mytype), intent(out), dimension(nxm, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (nclx) then + ! nxm = nx + do concurrent(k=1:nz, j=1:ny) + + ! Compute r.h.s. + tx(1, j, k) = acix6*(ux(2, j, k) - ux(1, j, k)) & + + bcix6*(ux(3, j, k) - ux(nx, j, k)) + tx(2, j, k) = acix6*(ux(3, j, k) - ux(2, j, k)) & + + bcix6*(ux(4, j, k) - ux(1, j, k)) + do concurrent(i=3:nx - 2) + tx(i, j, k) = acix6*(ux(i + 1, j, k) - ux(i, j, k)) & + + bcix6*(ux(i + 2, j, k) - ux(i - 1, j, k)) + end do + tx(nx - 1, j, k) = acix6*(ux(nx, j, k) - ux(nx - 1, j, k)) & + + bcix6*(ux(1, j, k) - ux(nx - 2, j, k)) + tx(nx, j, k) = acix6*(ux(1, j, k) - ux(nx, j, k)) & + + bcix6*(ux(2, j, k) - ux(nx - 1, j, k)) + end do + + ! Solve tri-diagonal system + call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nxm = nx-1 + do concurrent(k=1:nz, j=1:ny) + + ! Compute r.h.s. + if (x3dop%npaire == 1) then + tx(1, j, k) = acix6*(ux(2, j, k) - ux(1, j, k)) & + + bcix6*(ux(3, j, k) - ux(2, j, k)) + tx(2, j, k) = acix6*(ux(3, j, k) - ux(2, j, k)) & + + bcix6*(ux(4, j, k) - ux(1, j, k)) + else + tx(1, j, k) = acix6*(ux(2, j, k) - ux(1, j, k)) & + + bcix6*(ux(3, j, k) - two*ux(1, j, k) + ux(2, j, k)) + tx(2, j, k) = acix6*(ux(3, j, k) - ux(2, j, k)) & + + bcix6*(ux(4, j, k) - ux(1, j, k)) + end if + do concurrent(i=3:nxm - 2) + tx(i, j, k) = acix6*(ux(i + 1, j, k) - ux(i, j, k)) & + + bcix6*(ux(i + 2, j, k) - ux(i - 1, j, k)) + end do + if (x3dop%npaire == 1) then + tx(nxm - 1, j, k) = acix6*(ux(nxm, j, k) - ux(nxm - 1, j, k)) & + + bcix6*(ux(nx, j, k) - ux(nxm - 2, j, k)) + tx(nxm, j, k) = acix6*(ux(nx, j, k) - ux(nxm, j, k)) & + + bcix6*(ux(nxm, j, k) - ux(nxm - 1, j, k)) + else + tx(nxm - 1, j, k) = acix6*(ux(nxm, j, k) - ux(nxm - 1, j, k)) & + + bcix6*(ux(nx, j, k) - ux(nxm - 2, j, k)) + tx(nxm, j, k) = acix6*(ux(nx, j, k) - ux(nxm, j, k)) & + + bcix6*(two*ux(nx, j, k) - ux(nxm, j, k) - ux(nxm - 1, j, k)) + end if + end do + + ! Solve tri-diagonal system + call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, nxm, ny, nz) + + end if + + end subroutine derxvp !******************************************************************** ! -subroutine interxvp(tx,ux,x3dop,nx,nxm,ny,nz) - - use x3d_operator_x_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, nxm, ny, nz - real(mytype), intent(out), dimension(nxm,ny,nz) :: tx - real(mytype), intent(in), dimension(nx,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (nclx) then - ! nxm = nx - do concurrent (k=1:nz, j=1:ny) - - ! Compute r.h.s. - tx(1,j,k) = aicix6*(ux(2,j,k)+ux(1 ,j,k)) & - + bicix6*(ux(3,j,k)+ux(nx,j,k)) & - + cicix6*(ux(4,j,k)+ux(nx-1,j,k)) & - + dicix6*(ux(5,j,k)+ux(nx-2,j,k)) - tx(2,j,k) = aicix6*(ux(3,j,k)+ux(2 ,j,k)) & - + bicix6*(ux(4,j,k)+ux(1,j,k)) & - + cicix6*(ux(5,j,k)+ux(nx,j,k)) & - + dicix6*(ux(6,j,k)+ux(nx-1,j,k)) - tx(3,j,k) = aicix6*(ux(4,j,k)+ux(3 ,j,k)) & - + bicix6*(ux(5,j,k)+ux(2,j,k)) & - + cicix6*(ux(6,j,k)+ux(1,j,k)) & - + dicix6*(ux(7,j,k)+ux(nx,j,k)) - do concurrent (i=4:nx-4) - tx(i,j,k) = aicix6*(ux(i+1,j,k)+ux(i,j,k)) & - + bicix6*(ux(i+2,j,k)+ux(i-1,j,k)) & - + cicix6*(ux(i+3,j,k)+ux(i-2,j,k)) & - + dicix6*(ux(i+4,j,k)+ux(i-3,j,k)) - enddo - tx(nx-3,j,k) = aicix6*(ux(nx-2,j,k)+ux(nx-3,j,k)) & - + bicix6*(ux(nx-1,j,k)+ux(nx-4,j,k)) & - + cicix6*(ux(nx,j,k)+ux(nx-5,j,k)) & - + dicix6*(ux(1,j,k)+ux(nx-6,j,k)) - tx(nx-2,j,k) = aicix6*(ux(nx-1,j,k)+ux(nx-2,j,k)) & - + bicix6*(ux(nx ,j,k)+ux(nx-3,j,k)) & - + cicix6*(ux(1,j,k)+ux(nx-4,j,k)) & - + dicix6*(ux(2,j,k)+ux(nx-5,j,k)) - tx(nx-1,j,k) = aicix6*(ux(nx,j,k)+ux(nx-1,j,k)) & - + bicix6*(ux(1 ,j,k)+ux(nx-2,j,k)) & - + cicix6*(ux(2,j,k)+ux(nx-3,j,k)) & - + dicix6*(ux(3,j,k)+ux(nx-4,j,k)) - tx(nx ,j,k) = aicix6*(ux(1,j,k)+ux(nx,j,k)) & - + bicix6*(ux(2,j,k)+ux(nx-1,j,k)) & - + cicix6*(ux(3,j,k)+ux(nx-2,j,k)) & - + dicix6*(ux(4,j,k)+ux(nx-3,j,k)) - enddo - - ! Solve tri-diagonal system - call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nxm = nx-1 - if (x3dop%npaire==1) then - do concurrent (k=1:nz, j=1:ny) - - ! Compute r.h.s. - tx(1,j,k) = aicix6*(ux(2,j,k)+ux(1,j,k)) & - + bicix6*(ux(3,j,k)+ux(2,j,k)) & - + cicix6*(ux(4,j,k)+ux(3,j,k)) & - + dicix6*(ux(5,j,k)+ux(4,j,k)) - tx(2,j,k) = aicix6*(ux(3,j,k)+ux(2,j,k)) & - + bicix6*(ux(4,j,k)+ux(1,j,k)) & - + cicix6*(ux(5,j,k)+ux(2,j,k)) & - + dicix6*(ux(6,j,k)+ux(3,j,k)) - tx(3,j,k) = aicix6*(ux(4,j,k)+ux(3,j,k)) & - + bicix6*(ux(5,j,k)+ux(2,j,k)) & - + cicix6*(ux(6,j,k)+ux(1,j,k)) & - + dicix6*(ux(7,j,k)+ux(2,j,k)) - do concurrent (i=4:nxm-3) - tx(i,j,k) = aicix6*(ux(i+1,j,k)+ux(i,j,k)) & - + bicix6*(ux(i+2,j,k)+ux(i-1,j,k)) & - + cicix6*(ux(i+3,j,k)+ux(i-2,j,k)) & - + dicix6*(ux(i+4,j,k)+ux(i-3,j,k)) - enddo - tx(nxm-2,j,k) = aicix6*(ux(nxm-1,j,k)+ux(nxm-2,j,k)) & - + bicix6*(ux(nxm,j,k)+ux(nxm-3,j,k)) & - + cicix6*(ux(nx,j,k)+ux(nxm-4,j,k)) & - + dicix6*(ux(nxm,j,k)+ux(nxm-5,j,k)) - tx(nxm-1,j,k) = aicix6*(ux(nxm,j,k)+ux(nxm-1,j,k)) & - + bicix6*(ux(nx,j,k)+ux(nxm-2,j,k)) & - + cicix6*(ux(nxm,j,k)+ux(nxm-3,j,k)) & - + dicix6*(ux(nxm-1,j,k)+ux(nxm-4,j,k)) - tx(nxm ,j,k) = aicix6*(ux(nx,j,k)+ux(nxm,j,k)) & - + bicix6*(ux(nxm,j,k)+ux(nxm-1,j,k)) & - + cicix6*(ux(nxm-1,j,k)+ux(nxm-2,j,k)) & - + dicix6*(ux(nxm-2,j,k)+ux(nxm-3,j,k)) - enddo - - ! Solve tri-diagonal system - call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, nxm, ny, nz) - - endif - endif - -end subroutine interxvp + subroutine interxvp(tx, ux, x3dop, nx, nxm, ny, nz) + + use x3d_operator_x_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, nxm, ny, nz + real(mytype), intent(out), dimension(nxm, ny, nz) :: tx + real(mytype), intent(in), dimension(nx, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (nclx) then + ! nxm = nx + do concurrent(k=1:nz, j=1:ny) + + ! Compute r.h.s. + tx(1, j, k) = aicix6*(ux(2, j, k) + ux(1, j, k)) & + + bicix6*(ux(3, j, k) + ux(nx, j, k)) & + + cicix6*(ux(4, j, k) + ux(nx - 1, j, k)) & + + dicix6*(ux(5, j, k) + ux(nx - 2, j, k)) + tx(2, j, k) = aicix6*(ux(3, j, k) + ux(2, j, k)) & + + bicix6*(ux(4, j, k) + ux(1, j, k)) & + + cicix6*(ux(5, j, k) + ux(nx, j, k)) & + + dicix6*(ux(6, j, k) + ux(nx - 1, j, k)) + tx(3, j, k) = aicix6*(ux(4, j, k) + ux(3, j, k)) & + + bicix6*(ux(5, j, k) + ux(2, j, k)) & + + cicix6*(ux(6, j, k) + ux(1, j, k)) & + + dicix6*(ux(7, j, k) + ux(nx, j, k)) + do concurrent(i=4:nx - 4) + tx(i, j, k) = aicix6*(ux(i + 1, j, k) + ux(i, j, k)) & + + bicix6*(ux(i + 2, j, k) + ux(i - 1, j, k)) & + + cicix6*(ux(i + 3, j, k) + ux(i - 2, j, k)) & + + dicix6*(ux(i + 4, j, k) + ux(i - 3, j, k)) + end do + tx(nx - 3, j, k) = aicix6*(ux(nx - 2, j, k) + ux(nx - 3, j, k)) & + + bicix6*(ux(nx - 1, j, k) + ux(nx - 4, j, k)) & + + cicix6*(ux(nx, j, k) + ux(nx - 5, j, k)) & + + dicix6*(ux(1, j, k) + ux(nx - 6, j, k)) + tx(nx - 2, j, k) = aicix6*(ux(nx - 1, j, k) + ux(nx - 2, j, k)) & + + bicix6*(ux(nx, j, k) + ux(nx - 3, j, k)) & + + cicix6*(ux(1, j, k) + ux(nx - 4, j, k)) & + + dicix6*(ux(2, j, k) + ux(nx - 5, j, k)) + tx(nx - 1, j, k) = aicix6*(ux(nx, j, k) + ux(nx - 1, j, k)) & + + bicix6*(ux(1, j, k) + ux(nx - 2, j, k)) & + + cicix6*(ux(2, j, k) + ux(nx - 3, j, k)) & + + dicix6*(ux(3, j, k) + ux(nx - 4, j, k)) + tx(nx, j, k) = aicix6*(ux(1, j, k) + ux(nx, j, k)) & + + bicix6*(ux(2, j, k) + ux(nx - 1, j, k)) & + + cicix6*(ux(3, j, k) + ux(nx - 2, j, k)) & + + dicix6*(ux(4, j, k) + ux(nx - 3, j, k)) + end do + + ! Solve tri-diagonal system + call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nxm = nx-1 + if (x3dop%npaire == 1) then + do concurrent(k=1:nz, j=1:ny) + + ! Compute r.h.s. + tx(1, j, k) = aicix6*(ux(2, j, k) + ux(1, j, k)) & + + bicix6*(ux(3, j, k) + ux(2, j, k)) & + + cicix6*(ux(4, j, k) + ux(3, j, k)) & + + dicix6*(ux(5, j, k) + ux(4, j, k)) + tx(2, j, k) = aicix6*(ux(3, j, k) + ux(2, j, k)) & + + bicix6*(ux(4, j, k) + ux(1, j, k)) & + + cicix6*(ux(5, j, k) + ux(2, j, k)) & + + dicix6*(ux(6, j, k) + ux(3, j, k)) + tx(3, j, k) = aicix6*(ux(4, j, k) + ux(3, j, k)) & + + bicix6*(ux(5, j, k) + ux(2, j, k)) & + + cicix6*(ux(6, j, k) + ux(1, j, k)) & + + dicix6*(ux(7, j, k) + ux(2, j, k)) + do concurrent(i=4:nxm - 3) + tx(i, j, k) = aicix6*(ux(i + 1, j, k) + ux(i, j, k)) & + + bicix6*(ux(i + 2, j, k) + ux(i - 1, j, k)) & + + cicix6*(ux(i + 3, j, k) + ux(i - 2, j, k)) & + + dicix6*(ux(i + 4, j, k) + ux(i - 3, j, k)) + end do + tx(nxm - 2, j, k) = aicix6*(ux(nxm - 1, j, k) + ux(nxm - 2, j, k)) & + + bicix6*(ux(nxm, j, k) + ux(nxm - 3, j, k)) & + + cicix6*(ux(nx, j, k) + ux(nxm - 4, j, k)) & + + dicix6*(ux(nxm, j, k) + ux(nxm - 5, j, k)) + tx(nxm - 1, j, k) = aicix6*(ux(nxm, j, k) + ux(nxm - 1, j, k)) & + + bicix6*(ux(nx, j, k) + ux(nxm - 2, j, k)) & + + cicix6*(ux(nxm, j, k) + ux(nxm - 3, j, k)) & + + dicix6*(ux(nxm - 1, j, k) + ux(nxm - 4, j, k)) + tx(nxm, j, k) = aicix6*(ux(nx, j, k) + ux(nxm, j, k)) & + + bicix6*(ux(nxm, j, k) + ux(nxm - 1, j, k)) & + + cicix6*(ux(nxm - 1, j, k) + ux(nxm - 2, j, k)) & + + dicix6*(ux(nxm - 2, j, k) + ux(nxm - 3, j, k)) + end do + + ! Solve tri-diagonal system + call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, nxm, ny, nz) + + end if + end if + + end subroutine interxvp !******************************************************************** ! -subroutine derxpv(tx,ux,x3dop,nxm,nx,ny,nz) - - use x3d_operator_x_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, nxm, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nxm,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (nclx) then - ! nxm = nx - do concurrent (k=1:nz, j=1:ny) - - ! Compute r.h.s. - tx(1,j,k) = acix6*(ux(1,j,k)-ux(nx ,j,k)) & - + bcix6*(ux(2,j,k)-ux(nx-1,j,k)) - tx(2,j,k) = acix6*(ux(2,j,k)-ux(1 ,j,k)) & - + bcix6*(ux(3,j,k)-ux(nx,j,k)) - do concurrent (i=3:nx-2) - tx(i,j,k) = acix6*(ux(i,j,k)-ux(i-1,j,k)) & - + bcix6*(ux(i+1,j,k)-ux(i-2,j,k)) - enddo - tx(nx-1,j,k) = acix6*(ux(nx-1,j,k)-ux(nx-2,j,k)) & - + bcix6*(ux(nx ,j,k)-ux(nx-3,j,k)) - tx(nx ,j,k) = acix6*(ux(nx,j,k)-ux(nx-1,j,k)) & - + bcix6*(ux(1,j,k)-ux(nx-2,j,k)) - enddo - - ! Solve tri-diagonal system - call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nxm = nx-1 - if (x3dop%npaire==1) then - do concurrent (k=1:nz, j=1:ny) - - ! Compute r.h.s. - tx(1,j,k) = zero - tx(2,j,k) = acix6*(ux(2,j,k)-ux(1,j,k)) & - + bcix6*(ux(3,j,k)-ux(1,j,k)) - do concurrent (i=3:nx-2) - tx(i,j,k) = acix6*(ux(i,j,k)-ux(i-1,j,k)) & - + bcix6*(ux(i+1,j,k)-ux(i-2,j,k)) - enddo - tx(nx-1,j,k) = acix6*(ux(nx-1,j,k)-ux(nx-2,j,k)) & - + bcix6*(ux(nx-1,j,k)-ux(nx-3,j,k)) - tx(nx,j,k) = zero - enddo - - ! Solve tri-diagonal system - call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) - - endif - endif - -end subroutine derxpv + subroutine derxpv(tx, ux, x3dop, nxm, nx, ny, nz) + + use x3d_operator_x_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, nxm, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nxm, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (nclx) then + ! nxm = nx + do concurrent(k=1:nz, j=1:ny) + + ! Compute r.h.s. + tx(1, j, k) = acix6*(ux(1, j, k) - ux(nx, j, k)) & + + bcix6*(ux(2, j, k) - ux(nx - 1, j, k)) + tx(2, j, k) = acix6*(ux(2, j, k) - ux(1, j, k)) & + + bcix6*(ux(3, j, k) - ux(nx, j, k)) + do concurrent(i=3:nx - 2) + tx(i, j, k) = acix6*(ux(i, j, k) - ux(i - 1, j, k)) & + + bcix6*(ux(i + 1, j, k) - ux(i - 2, j, k)) + end do + tx(nx - 1, j, k) = acix6*(ux(nx - 1, j, k) - ux(nx - 2, j, k)) & + + bcix6*(ux(nx, j, k) - ux(nx - 3, j, k)) + tx(nx, j, k) = acix6*(ux(nx, j, k) - ux(nx - 1, j, k)) & + + bcix6*(ux(1, j, k) - ux(nx - 2, j, k)) + end do + + ! Solve tri-diagonal system + call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nxm = nx-1 + if (x3dop%npaire == 1) then + do concurrent(k=1:nz, j=1:ny) + + ! Compute r.h.s. + tx(1, j, k) = zero + tx(2, j, k) = acix6*(ux(2, j, k) - ux(1, j, k)) & + + bcix6*(ux(3, j, k) - ux(1, j, k)) + do concurrent(i=3:nx - 2) + tx(i, j, k) = acix6*(ux(i, j, k) - ux(i - 1, j, k)) & + + bcix6*(ux(i + 1, j, k) - ux(i - 2, j, k)) + end do + tx(nx - 1, j, k) = acix6*(ux(nx - 1, j, k) - ux(nx - 2, j, k)) & + + bcix6*(ux(nx - 1, j, k) - ux(nx - 3, j, k)) + tx(nx, j, k) = zero + end do + + ! Solve tri-diagonal system + call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) + + end if + end if + + end subroutine derxpv !******************************************************************** ! -subroutine interxpv(tx,ux,x3dop,nxm,nx,ny,nz) - - use x3d_operator_x_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, nxm, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tx - real(mytype), intent(in), dimension(nxm,ny,nz) :: ux - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (nclx) then - ! nxm = nx - do concurrent (k=1:nz, j=1:ny) - - ! Compute r.h.s. - tx(1,j,k) = aicix6*(ux(1,j,k)+ux(nx ,j,k)) & - + bicix6*(ux(2,j,k)+ux(nx-1,j,k)) & - + cicix6*(ux(3,j,k)+ux(nx-2,j,k)) & - + dicix6*(ux(4,j,k)+ux(nx-3,j,k)) - tx(2,j,k) = aicix6*(ux(2,j,k)+ux(1 ,j,k)) & - + bicix6*(ux(3,j,k)+ux(nx,j,k)) & - + cicix6*(ux(4,j,k)+ux(nx-1,j,k)) & - + dicix6*(ux(5,j,k)+ux(nx-2,j,k)) - tx(3,j,k) = aicix6*(ux(3,j,k)+ux(2 ,j,k)) & - + bicix6*(ux(4,j,k)+ux(1,j,k)) & - + cicix6*(ux(5,j,k)+ux(nx,j,k)) & - + dicix6*(ux(6,j,k)+ux(nx-1,j,k)) - tx(4,j,k) = aicix6*(ux(4,j,k)+ux(3 ,j,k)) & - + bicix6*(ux(5,j,k)+ux(2,j,k)) & - + cicix6*(ux(6,j,k)+ux(1,j,k)) & - + dicix6*(ux(7,j,k)+ux(nx,j,k)) - do concurrent (i=5:nx-3) - tx(i,j,k) = aicix6*(ux(i,j,k)+ux(i-1,j,k)) & - + bicix6*(ux(i+1,j,k)+ux(i-2,j,k)) & - + cicix6*(ux(i+2,j,k)+ux(i-3,j,k)) & - + dicix6*(ux(i+3,j,k)+ux(i-4,j,k)) - enddo - tx(nx-2,j,k) = aicix6*(ux(nx-2,j,k)+ux(nx-3,j,k)) & - + bicix6*(ux(nx-1,j,k)+ux(nx-4,j,k)) & - + cicix6*(ux(nx,j,k)+ux(nx-5,j,k)) & - + dicix6*(ux(1,j,k)+ux(nx-6,j,k)) - tx(nx-1,j,k) = aicix6*(ux(nx-1,j,k)+ux(nx-2,j,k)) & - + bicix6*(ux(nx ,j,k)+ux(nx-3,j,k)) & - + cicix6*(ux(1,j,k)+ux(nx-4,j,k)) & - + dicix6*(ux(2,j,k)+ux(nx-5,j,k)) - tx(nx ,j,k) = aicix6*(ux(nx,j,k)+ux(nx-1,j,k)) & - + bicix6*(ux(1,j,k)+ux(nx-2,j,k)) & - + cicix6*(ux(2,j,k)+ux(nx-3,j,k)) & - + dicix6*(ux(3,j,k)+ux(nx-4,j,k)) - enddo - - ! Solve tri-diagonal system - call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nxm = nx-1 - if (x3dop%npaire==1) then - do concurrent (k=1:nz, j=1:ny) - - ! Compute r.h.s. - tx(1,j,k) = aicix6*(ux(1,j,k)+ux(1,j,k)) & - + bicix6*(ux(2,j,k)+ux(2,j,k)) & - + cicix6*(ux(3,j,k)+ux(3,j,k)) & - + dicix6*(ux(4,j,k)+ux(4,j,k)) - tx(2,j,k) = aicix6*(ux(2,j,k)+ux(1,j,k)) & - + bicix6*(ux(3,j,k)+ux(1,j,k)) & - + cicix6*(ux(4,j,k)+ux(2,j,k)) & - + dicix6*(ux(5,j,k)+ux(3,j,k)) - tx(3,j,k) = aicix6*(ux(3,j,k)+ux(2,j,k)) & - + bicix6*(ux(4,j,k)+ux(1,j,k)) & - + cicix6*(ux(5,j,k)+ux(1,j,k)) & - + dicix6*(ux(6,j,k)+ux(2,j,k)) - tx(4,j,k) = aicix6*(ux(4,j,k)+ux(3,j,k)) & - + bicix6*(ux(5,j,k)+ux(2,j,k)) & - + cicix6*(ux(6,j,k)+ux(1,j,k)) & - + dicix6*(ux(7,j,k)+ux(1,j,k)) - do concurrent (i=5:nx-4) - tx(i,j,k) = aicix6*(ux(i,j,k)+ux(i-1,j,k)) & - + bicix6*(ux(i+1,j,k)+ux(i-2,j,k)) & - + cicix6*(ux(i+2,j,k)+ux(i-3,j,k)) & - + dicix6*(ux(i+3,j,k)+ux(i-4,j,k)) - enddo - tx(nx-3,j,k) = aicix6*(ux(nx-3,j,k)+ux(nx-4,j,k)) & - + bicix6*(ux(nx-2,j,k)+ux(nx-5,j,k)) & - + cicix6*(ux(nx-1,j,k)+ux(nx-6,j,k)) & - + dicix6*(ux(nx-1,j,k)+ux(nx-7,j,k)) - tx(nx-2,j,k) = aicix6*(ux(nx-2,j,k)+ux(nx-3,j,k)) & - + bicix6*(ux(nx-1,j,k)+ux(nx-4,j,k)) & - + cicix6*(ux(nx-1,j,k)+ux(nx-5,j,k)) & - + dicix6*(ux(nx-2,j,k)+ux(nx-6,j,k)) - tx(nx-1,j,k) = aicix6*(ux(nx-1,j,k)+ux(nx-2,j,k)) & - + bicix6*(ux(nx-1,j,k)+ux(nx-3,j,k)) & - + cicix6*(ux(nx-2,j,k)+ux(nx-4,j,k)) & - + dicix6*(ux(nx-3,j,k)+ux(nx-5,j,k)) - tx(nx ,j,k) = aicix6*(ux(nx-1,j,k)+ux(nx-1,j,k)) & - + bicix6*(ux(nx-2,j,k)+ux(nx-2,j,k)) & - + cicix6*(ux(nx-3,j,k)+ux(nx-3,j,k)) & - + dicix6*(ux(nx-4,j,k)+ux(nx-4,j,k)) - enddo - - ! Solve tri-diagonal system - call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) - - endif - endif - -end subroutine interxpv + subroutine interxpv(tx, ux, x3dop, nxm, nx, ny, nz) + + use x3d_operator_x_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, nxm, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tx + real(mytype), intent(in), dimension(nxm, ny, nz) :: ux + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (nclx) then + ! nxm = nx + do concurrent(k=1:nz, j=1:ny) + + ! Compute r.h.s. + tx(1, j, k) = aicix6*(ux(1, j, k) + ux(nx, j, k)) & + + bicix6*(ux(2, j, k) + ux(nx - 1, j, k)) & + + cicix6*(ux(3, j, k) + ux(nx - 2, j, k)) & + + dicix6*(ux(4, j, k) + ux(nx - 3, j, k)) + tx(2, j, k) = aicix6*(ux(2, j, k) + ux(1, j, k)) & + + bicix6*(ux(3, j, k) + ux(nx, j, k)) & + + cicix6*(ux(4, j, k) + ux(nx - 1, j, k)) & + + dicix6*(ux(5, j, k) + ux(nx - 2, j, k)) + tx(3, j, k) = aicix6*(ux(3, j, k) + ux(2, j, k)) & + + bicix6*(ux(4, j, k) + ux(1, j, k)) & + + cicix6*(ux(5, j, k) + ux(nx, j, k)) & + + dicix6*(ux(6, j, k) + ux(nx - 1, j, k)) + tx(4, j, k) = aicix6*(ux(4, j, k) + ux(3, j, k)) & + + bicix6*(ux(5, j, k) + ux(2, j, k)) & + + cicix6*(ux(6, j, k) + ux(1, j, k)) & + + dicix6*(ux(7, j, k) + ux(nx, j, k)) + do concurrent(i=5:nx - 3) + tx(i, j, k) = aicix6*(ux(i, j, k) + ux(i - 1, j, k)) & + + bicix6*(ux(i + 1, j, k) + ux(i - 2, j, k)) & + + cicix6*(ux(i + 2, j, k) + ux(i - 3, j, k)) & + + dicix6*(ux(i + 3, j, k) + ux(i - 4, j, k)) + end do + tx(nx - 2, j, k) = aicix6*(ux(nx - 2, j, k) + ux(nx - 3, j, k)) & + + bicix6*(ux(nx - 1, j, k) + ux(nx - 4, j, k)) & + + cicix6*(ux(nx, j, k) + ux(nx - 5, j, k)) & + + dicix6*(ux(1, j, k) + ux(nx - 6, j, k)) + tx(nx - 1, j, k) = aicix6*(ux(nx - 1, j, k) + ux(nx - 2, j, k)) & + + bicix6*(ux(nx, j, k) + ux(nx - 3, j, k)) & + + cicix6*(ux(1, j, k) + ux(nx - 4, j, k)) & + + dicix6*(ux(2, j, k) + ux(nx - 5, j, k)) + tx(nx, j, k) = aicix6*(ux(nx, j, k) + ux(nx - 1, j, k)) & + + bicix6*(ux(1, j, k) + ux(nx - 2, j, k)) & + + cicix6*(ux(2, j, k) + ux(nx - 3, j, k)) & + + dicix6*(ux(3, j, k) + ux(nx - 4, j, k)) + end do + + ! Solve tri-diagonal system + call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nxm = nx-1 + if (x3dop%npaire == 1) then + do concurrent(k=1:nz, j=1:ny) + + ! Compute r.h.s. + tx(1, j, k) = aicix6*(ux(1, j, k) + ux(1, j, k)) & + + bicix6*(ux(2, j, k) + ux(2, j, k)) & + + cicix6*(ux(3, j, k) + ux(3, j, k)) & + + dicix6*(ux(4, j, k) + ux(4, j, k)) + tx(2, j, k) = aicix6*(ux(2, j, k) + ux(1, j, k)) & + + bicix6*(ux(3, j, k) + ux(1, j, k)) & + + cicix6*(ux(4, j, k) + ux(2, j, k)) & + + dicix6*(ux(5, j, k) + ux(3, j, k)) + tx(3, j, k) = aicix6*(ux(3, j, k) + ux(2, j, k)) & + + bicix6*(ux(4, j, k) + ux(1, j, k)) & + + cicix6*(ux(5, j, k) + ux(1, j, k)) & + + dicix6*(ux(6, j, k) + ux(2, j, k)) + tx(4, j, k) = aicix6*(ux(4, j, k) + ux(3, j, k)) & + + bicix6*(ux(5, j, k) + ux(2, j, k)) & + + cicix6*(ux(6, j, k) + ux(1, j, k)) & + + dicix6*(ux(7, j, k) + ux(1, j, k)) + do concurrent(i=5:nx - 4) + tx(i, j, k) = aicix6*(ux(i, j, k) + ux(i - 1, j, k)) & + + bicix6*(ux(i + 1, j, k) + ux(i - 2, j, k)) & + + cicix6*(ux(i + 2, j, k) + ux(i - 3, j, k)) & + + dicix6*(ux(i + 3, j, k) + ux(i - 4, j, k)) + end do + tx(nx - 3, j, k) = aicix6*(ux(nx - 3, j, k) + ux(nx - 4, j, k)) & + + bicix6*(ux(nx - 2, j, k) + ux(nx - 5, j, k)) & + + cicix6*(ux(nx - 1, j, k) + ux(nx - 6, j, k)) & + + dicix6*(ux(nx - 1, j, k) + ux(nx - 7, j, k)) + tx(nx - 2, j, k) = aicix6*(ux(nx - 2, j, k) + ux(nx - 3, j, k)) & + + bicix6*(ux(nx - 1, j, k) + ux(nx - 4, j, k)) & + + cicix6*(ux(nx - 1, j, k) + ux(nx - 5, j, k)) & + + dicix6*(ux(nx - 2, j, k) + ux(nx - 6, j, k)) + tx(nx - 1, j, k) = aicix6*(ux(nx - 1, j, k) + ux(nx - 2, j, k)) & + + bicix6*(ux(nx - 1, j, k) + ux(nx - 3, j, k)) & + + cicix6*(ux(nx - 2, j, k) + ux(nx - 4, j, k)) & + + dicix6*(ux(nx - 3, j, k) + ux(nx - 5, j, k)) + tx(nx, j, k) = aicix6*(ux(nx - 1, j, k) + ux(nx - 1, j, k)) & + + bicix6*(ux(nx - 2, j, k) + ux(nx - 2, j, k)) & + + cicix6*(ux(nx - 3, j, k) + ux(nx - 3, j, k)) & + + dicix6*(ux(nx - 4, j, k) + ux(nx - 4, j, k)) + end do + + ! Solve tri-diagonal system + call xthomas(tx, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) + + end if + end if + + end subroutine interxpv !******************************************************************** ! -subroutine interyvp(ty,uy,x3dop,nx,ny,nym,nz) - - USE x3d_operator_y_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nym, nz - real(mytype), intent(out), dimension(nx,nym,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (ncly) then - ! nym = ny - do concurrent (k=1:nz) - - ! Compute r.h.s. - do concurrent (i=1:nx) - ty(i,1,k) = aiciy6*(uy(i,2,k)+uy(i,1,k)) & - + biciy6*(uy(i,3,k)+uy(i,ny,k)) & - + ciciy6*(uy(i,4,k)+uy(i,ny-1,k)) & - + diciy6*(uy(i,5,k)+uy(i,ny-2,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = aiciy6*(uy(i,3,k)+uy(i,2,k)) & - + biciy6*(uy(i,4,k)+uy(i,1,k)) & - + ciciy6*(uy(i,5,k)+uy(i,ny,k)) & - + diciy6*(uy(i,6,k)+uy(i,ny-1,k)) - enddo - do concurrent (i=1:nx) - ty(i,3,k) = aiciy6*(uy(i,4,k)+uy(i,3,k)) & - + biciy6*(uy(i,5,k)+uy(i,2,k)) & - + ciciy6*(uy(i,6,k)+uy(i,1,k)) & - + diciy6*(uy(i,7,k)+uy(i,ny,k)) - enddo - do concurrent (j=4:ny-4, i=1:nx) - ty(i,j,k) = aiciy6*(uy(i,j+1,k)+uy(i,j,k)) & - + biciy6*(uy(i,j+2,k)+uy(i,j-1,k)) & - + ciciy6*(uy(i,j+3,k)+uy(i,j-2,k)) & - + diciy6*(uy(i,j+4,k)+uy(i,j-3,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-3,k) = aiciy6*(uy(i,ny-2,k)+uy(i,ny-3,k)) & - + biciy6*(uy(i,ny-1,k)+uy(i,ny-4,k)) & - + ciciy6*(uy(i,ny,k)+uy(i,ny-5,k)) & - + diciy6*(uy(i,1,k)+uy(i,ny-6,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-2,k) = aiciy6*(uy(i,ny-1,k)+uy(i,ny-2,k)) & - + biciy6*(uy(i,ny,k)+uy(i,ny-3,k)) & - + ciciy6*(uy(i,1,k)+uy(i,ny-4,k)) & - + diciy6*(uy(i,2,k)+uy(i,ny-5,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = aiciy6*(uy(i,ny,k)+uy(i,ny-1,k)) & - + biciy6*(uy(i,1,k)+uy(i,ny-2,k)) & - + ciciy6*(uy(i,2,k)+uy(i,ny-3,k)) & - + diciy6*(uy(i,3,k)+uy(i,ny-4,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny ,k) = aiciy6*(uy(i,1,k)+uy(i,ny,k)) & - + biciy6*(uy(i,2,k)+uy(i,ny-1,k)) & - + ciciy6*(uy(i,3,k)+uy(i,ny-2,k)) & - + diciy6*(uy(i,4,k)+uy(i,ny-3,k)) - enddo - enddo - - ! Solve tri-diagonal system - call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nym = ny-1 - if (x3dop%npaire==1) then - do concurrent (k=1:nz) - - ! Compute r.h.s. - do concurrent (i=1:nx) - ty(i,1,k) = aiciy6*(uy(i,2,k)+uy(i,1,k)) & - + biciy6*(uy(i,3,k)+uy(i,2,k)) & - + ciciy6*(uy(i,4,k)+uy(i,3,k)) & - + diciy6*(uy(i,5,k)+uy(i,4,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = aiciy6*(uy(i,3,k)+uy(i,2,k)) & - + biciy6*(uy(i,4,k)+uy(i,1,k)) & - + ciciy6*(uy(i,5,k)+uy(i,2,k)) & - + diciy6*(uy(i,6,k)+uy(i,3,k)) - enddo - do concurrent (i=1:nx) - ty(i,3,k) = aiciy6*(uy(i,4,k)+uy(i,3,k)) & - + biciy6*(uy(i,5,k)+uy(i,2,k)) & - + ciciy6*(uy(i,6,k)+uy(i,1,k)) & - + diciy6*(uy(i,7,k)+uy(i,2,k)) - enddo - do concurrent (j=4:nym-3, i=1:nx) - ty(i,j,k) = aiciy6*(uy(i,j+1,k)+uy(i,j,k)) & - + biciy6*(uy(i,j+2,k)+uy(i,j-1,k)) & - + ciciy6*(uy(i,j+3,k)+uy(i,j-2,k)) & - + diciy6*(uy(i,j+4,k)+uy(i,j-3,k)) - enddo - do concurrent (i=1:nx) - ty(i,nym-2,k) = aiciy6*(uy(i,nym-1,k)+uy(i,nym-2,k)) & - + biciy6*(uy(i,nym,k)+uy(i,nym-3,k)) & - + ciciy6*(uy(i,ny,k)+uy(i,nym-4,k)) & - + diciy6*(uy(i,nym,k)+uy(i,nym-5,k)) - enddo - do concurrent (i=1:nx) - ty(i,nym-1,k) = aiciy6*(uy(i,nym,k)+uy(i,nym-1,k)) & - + biciy6*(uy(i,ny,k)+uy(i,nym-2,k)) & - + ciciy6*(uy(i,nym,k)+uy(i,nym-3,k)) & - + diciy6*(uy(i,nym-1,k)+uy(i,nym-4,k)) - enddo - do concurrent (i=1:nx) - ty(i,nym ,k) = aiciy6*(uy(i,ny,k)+uy(i,nym,k)) & - + biciy6*(uy(i,nym,k)+uy(i,nym-1,k)) & - + ciciy6*(uy(i,nym-1,k)+uy(i,nym-2,k)) & - + diciy6*(uy(i,nym-2,k)+uy(i,nym-3,k)) - enddo - enddo - - ! Solve tri-diagonal system - call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, nx, nym, nz) - - endif - endif - -end subroutine interyvp + subroutine interyvp(ty, uy, x3dop, nx, ny, nym, nz) + + USE x3d_operator_y_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nym, nz + real(mytype), intent(out), dimension(nx, nym, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (ncly) then + ! nym = ny + do concurrent(k=1:nz) + + ! Compute r.h.s. + do concurrent(i=1:nx) + ty(i, 1, k) = aiciy6*(uy(i, 2, k) + uy(i, 1, k)) & + + biciy6*(uy(i, 3, k) + uy(i, ny, k)) & + + ciciy6*(uy(i, 4, k) + uy(i, ny - 1, k)) & + + diciy6*(uy(i, 5, k) + uy(i, ny - 2, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = aiciy6*(uy(i, 3, k) + uy(i, 2, k)) & + + biciy6*(uy(i, 4, k) + uy(i, 1, k)) & + + ciciy6*(uy(i, 5, k) + uy(i, ny, k)) & + + diciy6*(uy(i, 6, k) + uy(i, ny - 1, k)) + end do + do concurrent(i=1:nx) + ty(i, 3, k) = aiciy6*(uy(i, 4, k) + uy(i, 3, k)) & + + biciy6*(uy(i, 5, k) + uy(i, 2, k)) & + + ciciy6*(uy(i, 6, k) + uy(i, 1, k)) & + + diciy6*(uy(i, 7, k) + uy(i, ny, k)) + end do + do concurrent(j=4:ny - 4, i=1:nx) + ty(i, j, k) = aiciy6*(uy(i, j + 1, k) + uy(i, j, k)) & + + biciy6*(uy(i, j + 2, k) + uy(i, j - 1, k)) & + + ciciy6*(uy(i, j + 3, k) + uy(i, j - 2, k)) & + + diciy6*(uy(i, j + 4, k) + uy(i, j - 3, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 3, k) = aiciy6*(uy(i, ny - 2, k) + uy(i, ny - 3, k)) & + + biciy6*(uy(i, ny - 1, k) + uy(i, ny - 4, k)) & + + ciciy6*(uy(i, ny, k) + uy(i, ny - 5, k)) & + + diciy6*(uy(i, 1, k) + uy(i, ny - 6, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 2, k) = aiciy6*(uy(i, ny - 1, k) + uy(i, ny - 2, k)) & + + biciy6*(uy(i, ny, k) + uy(i, ny - 3, k)) & + + ciciy6*(uy(i, 1, k) + uy(i, ny - 4, k)) & + + diciy6*(uy(i, 2, k) + uy(i, ny - 5, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = aiciy6*(uy(i, ny, k) + uy(i, ny - 1, k)) & + + biciy6*(uy(i, 1, k) + uy(i, ny - 2, k)) & + + ciciy6*(uy(i, 2, k) + uy(i, ny - 3, k)) & + + diciy6*(uy(i, 3, k) + uy(i, ny - 4, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = aiciy6*(uy(i, 1, k) + uy(i, ny, k)) & + + biciy6*(uy(i, 2, k) + uy(i, ny - 1, k)) & + + ciciy6*(uy(i, 3, k) + uy(i, ny - 2, k)) & + + diciy6*(uy(i, 4, k) + uy(i, ny - 3, k)) + end do + end do + + ! Solve tri-diagonal system + call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nym = ny-1 + if (x3dop%npaire == 1) then + do concurrent(k=1:nz) + + ! Compute r.h.s. + do concurrent(i=1:nx) + ty(i, 1, k) = aiciy6*(uy(i, 2, k) + uy(i, 1, k)) & + + biciy6*(uy(i, 3, k) + uy(i, 2, k)) & + + ciciy6*(uy(i, 4, k) + uy(i, 3, k)) & + + diciy6*(uy(i, 5, k) + uy(i, 4, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = aiciy6*(uy(i, 3, k) + uy(i, 2, k)) & + + biciy6*(uy(i, 4, k) + uy(i, 1, k)) & + + ciciy6*(uy(i, 5, k) + uy(i, 2, k)) & + + diciy6*(uy(i, 6, k) + uy(i, 3, k)) + end do + do concurrent(i=1:nx) + ty(i, 3, k) = aiciy6*(uy(i, 4, k) + uy(i, 3, k)) & + + biciy6*(uy(i, 5, k) + uy(i, 2, k)) & + + ciciy6*(uy(i, 6, k) + uy(i, 1, k)) & + + diciy6*(uy(i, 7, k) + uy(i, 2, k)) + end do + do concurrent(j=4:nym - 3, i=1:nx) + ty(i, j, k) = aiciy6*(uy(i, j + 1, k) + uy(i, j, k)) & + + biciy6*(uy(i, j + 2, k) + uy(i, j - 1, k)) & + + ciciy6*(uy(i, j + 3, k) + uy(i, j - 2, k)) & + + diciy6*(uy(i, j + 4, k) + uy(i, j - 3, k)) + end do + do concurrent(i=1:nx) + ty(i, nym - 2, k) = aiciy6*(uy(i, nym - 1, k) + uy(i, nym - 2, k)) & + + biciy6*(uy(i, nym, k) + uy(i, nym - 3, k)) & + + ciciy6*(uy(i, ny, k) + uy(i, nym - 4, k)) & + + diciy6*(uy(i, nym, k) + uy(i, nym - 5, k)) + end do + do concurrent(i=1:nx) + ty(i, nym - 1, k) = aiciy6*(uy(i, nym, k) + uy(i, nym - 1, k)) & + + biciy6*(uy(i, ny, k) + uy(i, nym - 2, k)) & + + ciciy6*(uy(i, nym, k) + uy(i, nym - 3, k)) & + + diciy6*(uy(i, nym - 1, k) + uy(i, nym - 4, k)) + end do + do concurrent(i=1:nx) + ty(i, nym, k) = aiciy6*(uy(i, ny, k) + uy(i, nym, k)) & + + biciy6*(uy(i, nym, k) + uy(i, nym - 1, k)) & + + ciciy6*(uy(i, nym - 1, k) + uy(i, nym - 2, k)) & + + diciy6*(uy(i, nym - 2, k) + uy(i, nym - 3, k)) + end do + end do + + ! Solve tri-diagonal system + call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, nx, nym, nz) + + end if + end if + + end subroutine interyvp !******************************************************************** ! -subroutine deryvp(ty,uy,x3dop,ppyi,nx,ny,nym,nz) - - USE x3d_operator_y_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nym, nz - real(mytype), intent(out), dimension(nx,nym,nz) :: ty - real(mytype), intent(in), dimension(nx,ny,nz) :: uy - real(mytype), intent(in), dimension(nym) :: ppyi - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (ncly) then - ! nym = ny - do concurrent (k=1:nz) - - ! Compute r.h.s. - do concurrent (i=1:nx) - ty(i,1,k) = aciy6*(uy(i,2,k)-uy(i,1,k)) & - + bciy6*(uy(i,3,k)-uy(i,ny,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = aciy6*(uy(i,3,k)-uy(i,2,k)) & - + bciy6*(uy(i,4,k)-uy(i,1,k)) - enddo - do concurrent (j=3:ny-2, i=1:nx) - ty(i,j,k) = aciy6*(uy(i,j+1,k)-uy(i,j,k)) & - + bciy6*(uy(i,j+2,k)-uy(i,j-1,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = aciy6*(uy(i,ny,k)-uy(i,ny-1,k)) & - + bciy6*(uy(i,1,k)-uy(i,ny-2,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny ,k) = aciy6*(uy(i,1,k)-uy(i,ny,k)) & - + bciy6*(uy(i,2,k)-uy(i,ny-1,k)) - enddo - enddo - - ! Solve tri-diagonal system - call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nym = ny-1 - if (x3dop%npaire==0) then - do concurrent (k=1:nz) - - ! Compute r.h.s. - do concurrent (i=1:nx) - ty(i,1,k) = aciy6*(uy(i,2,k)-uy(i,1,k)) & - + bciy6*(uy(i,3,k)-two*uy(i,1,k)+uy(i,2,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = aciy6*(uy(i,3,k)-uy(i,2,k)) & - + bciy6*(uy(i,4,k)-uy(i,1,k)) - enddo - do concurrent (j=3:nym-2, i=1:nx) - ty(i,j,k) = aciy6*(uy(i,j+1,k)-uy(i,j,k)) & - + bciy6*(uy(i,j+2,k)-uy(i,j-1,k)) - enddo - do concurrent (i=1:nx) - ty(i,nym-1,k) = aciy6*(uy(i,nym,k)-uy(i,nym-1,k)) & - + bciy6*(uy(i,ny,k)-uy(i,nym-2,k)) - enddo - do concurrent (i=1:nx) - ty(i,nym ,k) = aciy6*(uy(i,ny,k)-uy(i,nym,k)) & - + bciy6*(two*uy(i,ny,k)-uy(i,nym,k)-uy(i,nym-1,k)) - enddo - enddo - - ! Solve tri-diagonal system - call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, nx, nym, nz) - - endif - endif - - if (istret /= 0) then - do concurrent (k=1:nz, j=1:nym, i=1:nx) - ty(i,j,k) = ty(i,j,k) * ppyi(j) - enddo - endif - -end subroutine deryvp + subroutine deryvp(ty, uy, x3dop, ppyi, nx, ny, nym, nz) + + USE x3d_operator_y_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nym, nz + real(mytype), intent(out), dimension(nx, nym, nz) :: ty + real(mytype), intent(in), dimension(nx, ny, nz) :: uy + real(mytype), intent(in), dimension(nym) :: ppyi + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (ncly) then + ! nym = ny + do concurrent(k=1:nz) + + ! Compute r.h.s. + do concurrent(i=1:nx) + ty(i, 1, k) = aciy6*(uy(i, 2, k) - uy(i, 1, k)) & + + bciy6*(uy(i, 3, k) - uy(i, ny, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = aciy6*(uy(i, 3, k) - uy(i, 2, k)) & + + bciy6*(uy(i, 4, k) - uy(i, 1, k)) + end do + do concurrent(j=3:ny - 2, i=1:nx) + ty(i, j, k) = aciy6*(uy(i, j + 1, k) - uy(i, j, k)) & + + bciy6*(uy(i, j + 2, k) - uy(i, j - 1, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = aciy6*(uy(i, ny, k) - uy(i, ny - 1, k)) & + + bciy6*(uy(i, 1, k) - uy(i, ny - 2, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = aciy6*(uy(i, 1, k) - uy(i, ny, k)) & + + bciy6*(uy(i, 2, k) - uy(i, ny - 1, k)) + end do + end do + + ! Solve tri-diagonal system + call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nym = ny-1 + if (x3dop%npaire == 0) then + do concurrent(k=1:nz) + + ! Compute r.h.s. + do concurrent(i=1:nx) + ty(i, 1, k) = aciy6*(uy(i, 2, k) - uy(i, 1, k)) & + + bciy6*(uy(i, 3, k) - two*uy(i, 1, k) + uy(i, 2, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = aciy6*(uy(i, 3, k) - uy(i, 2, k)) & + + bciy6*(uy(i, 4, k) - uy(i, 1, k)) + end do + do concurrent(j=3:nym - 2, i=1:nx) + ty(i, j, k) = aciy6*(uy(i, j + 1, k) - uy(i, j, k)) & + + bciy6*(uy(i, j + 2, k) - uy(i, j - 1, k)) + end do + do concurrent(i=1:nx) + ty(i, nym - 1, k) = aciy6*(uy(i, nym, k) - uy(i, nym - 1, k)) & + + bciy6*(uy(i, ny, k) - uy(i, nym - 2, k)) + end do + do concurrent(i=1:nx) + ty(i, nym, k) = aciy6*(uy(i, ny, k) - uy(i, nym, k)) & + + bciy6*(two*uy(i, ny, k) - uy(i, nym, k) - uy(i, nym - 1, k)) + end do + end do + + ! Solve tri-diagonal system + call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, nx, nym, nz) + + end if + end if + + if (istret /= 0) then + do concurrent(k=1:nz, j=1:nym, i=1:nx) + ty(i, j, k) = ty(i, j, k)*ppyi(j) + end do + end if + + end subroutine deryvp !******************************************************************** ! -subroutine interypv(ty,uy,x3dop,nx,nym,ny,nz) - - USE x3d_operator_y_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nym, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,nym,nz) :: uy - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (ncly) then - ! nym = ny - do concurrent (k=1:nz) - - ! Compute r.h.s. - do concurrent (i=1:nx) - ty(i,1,k) = aiciy6*(uy(i,1,k)+uy(i,ny,k)) & - + biciy6*(uy(i,2,k)+uy(i,ny-1,k)) & - + ciciy6*(uy(i,3,k)+uy(i,ny-2,k)) & - + diciy6*(uy(i,4,k)+uy(i,ny-3,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = aiciy6*(uy(i,2,k)+uy(i,1,k)) & - + biciy6*(uy(i,3,k)+uy(i,ny,k)) & - + ciciy6*(uy(i,4,k)+uy(i,ny-1,k)) & - + diciy6*(uy(i,5,k)+uy(i,ny-2,k)) - enddo - do concurrent (i=1:nx) - ty(i,3,k) = aiciy6*(uy(i,3,k)+uy(i,2,k)) & - + biciy6*(uy(i,4,k)+uy(i,1,k)) & - + ciciy6*(uy(i,5,k)+uy(i,ny,k)) & - + diciy6*(uy(i,6,k)+uy(i,ny-1,k)) - enddo - do concurrent (i=1:nx) - ty(i,4,k) = aiciy6*(uy(i,4,k)+uy(i,3,k)) & - + biciy6*(uy(i,5,k)+uy(i,2,k)) & - + ciciy6*(uy(i,6,k)+uy(i,1,k)) & - + diciy6*(uy(i,7,k)+uy(i,ny,k)) - enddo - do concurrent (j=5:ny-3, i=1:nx) - ty(i,j,k) = aiciy6*(uy(i,j,k)+uy(i,j-1,k)) & - + biciy6*(uy(i,j+1,k)+uy(i,j-2,k)) & - + ciciy6*(uy(i,j+2,k)+uy(i,j-3,k)) & - + diciy6*(uy(i,j+3,k)+uy(i,j-4,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-2,k) = aiciy6*(uy(i,ny-2,k)+uy(i,ny-3,k)) & - + biciy6*(uy(i,ny-1,k)+uy(i,ny-4,k)) & - + ciciy6*(uy(i,ny,k)+uy(i,ny-5,k)) & - + diciy6*(uy(i,1,k)+uy(i,ny-6,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = aiciy6*(uy(i,ny-1,k)+uy(i,ny-2,k)) & - + biciy6*(uy(i,ny,k)+uy(i,ny-3,k)) & - + ciciy6*(uy(i,1,k)+uy(i,ny-4,k)) & - + diciy6*(uy(i,2,k)+uy(i,ny-5,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny ,k) = aiciy6*(uy(i,ny,k)+uy(i,ny-1,k)) & - + biciy6*(uy(i,1,k)+uy(i,ny-2,k)) & - + ciciy6*(uy(i,2,k)+uy(i,ny-3,k)) & - + diciy6*(uy(i,3,k)+uy(i,ny-4,k)) - enddo - enddo - - ! Solve tri-diagonal system - call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nym = ny-1 - if (x3dop%npaire==1) then - do concurrent (k=1:nz) - - ! Compute r.h.s. - do concurrent (i=1:nx) - ty(i,1,k) = aiciy6*(uy(i,1,k)+uy(i,1,k)) & - + biciy6*(uy(i,2,k)+uy(i,2,k)) & - + ciciy6*(uy(i,3,k)+uy(i,3,k)) & - + diciy6*(uy(i,4,k)+uy(i,4,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = aiciy6*(uy(i,2,k)+uy(i,1,k)) & - + biciy6*(uy(i,3,k)+uy(i,1,k)) & - + ciciy6*(uy(i,4,k)+uy(i,2,k)) & - + diciy6*(uy(i,5,k)+uy(i,3,k)) - enddo - do concurrent (i=1:nx) - ty(i,3,k) = aiciy6*(uy(i,3,k)+uy(i,2,k)) & - + biciy6*(uy(i,4,k)+uy(i,1,k)) & - + ciciy6*(uy(i,5,k)+uy(i,1,k)) & - + diciy6*(uy(i,6,k)+uy(i,2,k)) - enddo - do concurrent (i=1:nx) - ty(i,4,k) = aiciy6*(uy(i,4,k)+uy(i,3,k)) & - + biciy6*(uy(i,5,k)+uy(i,2,k)) & - + ciciy6*(uy(i,6,k)+uy(i,1,k)) & - + diciy6*(uy(i,7,k)+uy(i,1,k)) - enddo - do concurrent (j=5:ny-4, i=1:nx) - ty(i,j,k) = aiciy6*(uy(i,j,k)+uy(i,j-1,k)) & - + biciy6*(uy(i,j+1,k)+uy(i,j-2,k)) & - + ciciy6*(uy(i,j+2,k)+uy(i,j-3,k)) & - + diciy6*(uy(i,j+3,k)+uy(i,j-4,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-3,k) = aiciy6*(uy(i,ny-3,k)+uy(i,ny-4,k)) & - + biciy6*(uy(i,ny-2,k)+uy(i,ny-5,k)) & - + ciciy6*(uy(i,ny-1,k)+uy(i,ny-6,k)) & - + diciy6*(uy(i,ny-1,k)+uy(i,ny-7,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-2,k) = aiciy6*(uy(i,ny-2,k)+uy(i,ny-3,k)) & - + biciy6*(uy(i,ny-1,k)+uy(i,ny-4,k)) & - + ciciy6*(uy(i,ny-1,k)+uy(i,ny-5,k)) & - + diciy6*(uy(i,ny-2,k)+uy(i,ny-6,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = aiciy6*(uy(i,ny-1,k)+uy(i,ny-2,k)) & - + biciy6*(uy(i,ny-1,k)+uy(i,ny-3,k)) & - + ciciy6*(uy(i,ny-2,k)+uy(i,ny-4,k)) & - + diciy6*(uy(i,ny-3,k)+uy(i,ny-5,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny ,k) = aiciy6*(uy(i,ny-1,k)+uy(i,ny-1,k)) & - + biciy6*(uy(i,ny-2,k)+uy(i,ny-2,k)) & - + ciciy6*(uy(i,ny-3,k)+uy(i,ny-3,k)) & - + diciy6*(uy(i,ny-4,k)+uy(i,ny-4,k)) - enddo - enddo - - ! Solve tri-diagonal system - call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) - - endif - endif - -end subroutine interypv + subroutine interypv(ty, uy, x3dop, nx, nym, ny, nz) + + USE x3d_operator_y_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nym, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, nym, nz) :: uy + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (ncly) then + ! nym = ny + do concurrent(k=1:nz) + + ! Compute r.h.s. + do concurrent(i=1:nx) + ty(i, 1, k) = aiciy6*(uy(i, 1, k) + uy(i, ny, k)) & + + biciy6*(uy(i, 2, k) + uy(i, ny - 1, k)) & + + ciciy6*(uy(i, 3, k) + uy(i, ny - 2, k)) & + + diciy6*(uy(i, 4, k) + uy(i, ny - 3, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = aiciy6*(uy(i, 2, k) + uy(i, 1, k)) & + + biciy6*(uy(i, 3, k) + uy(i, ny, k)) & + + ciciy6*(uy(i, 4, k) + uy(i, ny - 1, k)) & + + diciy6*(uy(i, 5, k) + uy(i, ny - 2, k)) + end do + do concurrent(i=1:nx) + ty(i, 3, k) = aiciy6*(uy(i, 3, k) + uy(i, 2, k)) & + + biciy6*(uy(i, 4, k) + uy(i, 1, k)) & + + ciciy6*(uy(i, 5, k) + uy(i, ny, k)) & + + diciy6*(uy(i, 6, k) + uy(i, ny - 1, k)) + end do + do concurrent(i=1:nx) + ty(i, 4, k) = aiciy6*(uy(i, 4, k) + uy(i, 3, k)) & + + biciy6*(uy(i, 5, k) + uy(i, 2, k)) & + + ciciy6*(uy(i, 6, k) + uy(i, 1, k)) & + + diciy6*(uy(i, 7, k) + uy(i, ny, k)) + end do + do concurrent(j=5:ny - 3, i=1:nx) + ty(i, j, k) = aiciy6*(uy(i, j, k) + uy(i, j - 1, k)) & + + biciy6*(uy(i, j + 1, k) + uy(i, j - 2, k)) & + + ciciy6*(uy(i, j + 2, k) + uy(i, j - 3, k)) & + + diciy6*(uy(i, j + 3, k) + uy(i, j - 4, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 2, k) = aiciy6*(uy(i, ny - 2, k) + uy(i, ny - 3, k)) & + + biciy6*(uy(i, ny - 1, k) + uy(i, ny - 4, k)) & + + ciciy6*(uy(i, ny, k) + uy(i, ny - 5, k)) & + + diciy6*(uy(i, 1, k) + uy(i, ny - 6, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = aiciy6*(uy(i, ny - 1, k) + uy(i, ny - 2, k)) & + + biciy6*(uy(i, ny, k) + uy(i, ny - 3, k)) & + + ciciy6*(uy(i, 1, k) + uy(i, ny - 4, k)) & + + diciy6*(uy(i, 2, k) + uy(i, ny - 5, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = aiciy6*(uy(i, ny, k) + uy(i, ny - 1, k)) & + + biciy6*(uy(i, 1, k) + uy(i, ny - 2, k)) & + + ciciy6*(uy(i, 2, k) + uy(i, ny - 3, k)) & + + diciy6*(uy(i, 3, k) + uy(i, ny - 4, k)) + end do + end do + + ! Solve tri-diagonal system + call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nym = ny-1 + if (x3dop%npaire == 1) then + do concurrent(k=1:nz) + + ! Compute r.h.s. + do concurrent(i=1:nx) + ty(i, 1, k) = aiciy6*(uy(i, 1, k) + uy(i, 1, k)) & + + biciy6*(uy(i, 2, k) + uy(i, 2, k)) & + + ciciy6*(uy(i, 3, k) + uy(i, 3, k)) & + + diciy6*(uy(i, 4, k) + uy(i, 4, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = aiciy6*(uy(i, 2, k) + uy(i, 1, k)) & + + biciy6*(uy(i, 3, k) + uy(i, 1, k)) & + + ciciy6*(uy(i, 4, k) + uy(i, 2, k)) & + + diciy6*(uy(i, 5, k) + uy(i, 3, k)) + end do + do concurrent(i=1:nx) + ty(i, 3, k) = aiciy6*(uy(i, 3, k) + uy(i, 2, k)) & + + biciy6*(uy(i, 4, k) + uy(i, 1, k)) & + + ciciy6*(uy(i, 5, k) + uy(i, 1, k)) & + + diciy6*(uy(i, 6, k) + uy(i, 2, k)) + end do + do concurrent(i=1:nx) + ty(i, 4, k) = aiciy6*(uy(i, 4, k) + uy(i, 3, k)) & + + biciy6*(uy(i, 5, k) + uy(i, 2, k)) & + + ciciy6*(uy(i, 6, k) + uy(i, 1, k)) & + + diciy6*(uy(i, 7, k) + uy(i, 1, k)) + end do + do concurrent(j=5:ny - 4, i=1:nx) + ty(i, j, k) = aiciy6*(uy(i, j, k) + uy(i, j - 1, k)) & + + biciy6*(uy(i, j + 1, k) + uy(i, j - 2, k)) & + + ciciy6*(uy(i, j + 2, k) + uy(i, j - 3, k)) & + + diciy6*(uy(i, j + 3, k) + uy(i, j - 4, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 3, k) = aiciy6*(uy(i, ny - 3, k) + uy(i, ny - 4, k)) & + + biciy6*(uy(i, ny - 2, k) + uy(i, ny - 5, k)) & + + ciciy6*(uy(i, ny - 1, k) + uy(i, ny - 6, k)) & + + diciy6*(uy(i, ny - 1, k) + uy(i, ny - 7, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 2, k) = aiciy6*(uy(i, ny - 2, k) + uy(i, ny - 3, k)) & + + biciy6*(uy(i, ny - 1, k) + uy(i, ny - 4, k)) & + + ciciy6*(uy(i, ny - 1, k) + uy(i, ny - 5, k)) & + + diciy6*(uy(i, ny - 2, k) + uy(i, ny - 6, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = aiciy6*(uy(i, ny - 1, k) + uy(i, ny - 2, k)) & + + biciy6*(uy(i, ny - 1, k) + uy(i, ny - 3, k)) & + + ciciy6*(uy(i, ny - 2, k) + uy(i, ny - 4, k)) & + + diciy6*(uy(i, ny - 3, k) + uy(i, ny - 5, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = aiciy6*(uy(i, ny - 1, k) + uy(i, ny - 1, k)) & + + biciy6*(uy(i, ny - 2, k) + uy(i, ny - 2, k)) & + + ciciy6*(uy(i, ny - 3, k) + uy(i, ny - 3, k)) & + + diciy6*(uy(i, ny - 4, k) + uy(i, ny - 4, k)) + end do + end do + + ! Solve tri-diagonal system + call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) + + end if + end if + + end subroutine interypv !******************************************************************** ! -subroutine derypv(ty,uy,x3dop,ppy,nx,nym,ny,nz) - - USE x3d_operator_y_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nym, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: ty - real(mytype), intent(in), dimension(nx,nym,nz) :: uy - real(mytype), intent(in), dimension(ny) :: ppy - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (ncly) then - ! nym = ny - do concurrent (k=1:nz) - - ! Compute r.h.s. - do concurrent (i=1:nx) - ty(i,1,k) = aciy6*(uy(i,1,k)-uy(i,ny,k)) & - + bciy6*(uy(i,2,k)-uy(i,ny-1,k)) - enddo - do concurrent (i=1:nx) - ty(i,2,k) = aciy6*(uy(i,2,k)-uy(i,1,k)) & - + bciy6*(uy(i,3,k)-uy(i,ny,k)) - enddo - do concurrent (j=3:ny-2, i=1:nx) - ty(i,j,k) = aciy6*(uy(i,j,k)-uy(i,j-1,k)) & - + bciy6*(uy(i,j+1,k)-uy(i,j-2,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = aciy6*(uy(i,ny-1,k)-uy(i,ny-2,k)) & - + bciy6*(uy(i,ny,k)-uy(i,ny-3,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny,k) = aciy6*(uy(i,ny,k)-uy(i,ny-1,k)) & - + bciy6*(uy(i,1,k)-uy(i,ny-2,k)) - enddo - enddo - - ! Solve tri-diagonal system - call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nym = ny-1 - if (x3dop%npaire==1) then - do concurrent (k=1:nz) - - ! Compute r.h.s. - do concurrent (i=1:nx) - ty(i,1,k) = zero - enddo - do concurrent (i=1:nx) - ty(i,2,k) = aciy6*(uy(i,2,k)-uy(i,1,k)) & - + bciy6*(uy(i,3,k)-uy(i,1,k)) - enddo - do concurrent (j=3:ny-2, i=1:nx) - ty(i,j,k) = aciy6*(uy(i,j,k)-uy(i,j-1,k)) & - + bciy6*(uy(i,j+1,k)-uy(i,j-2,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny-1,k) = aciy6*(uy(i,ny-1,k)-uy(i,ny-2,k)) & - + bciy6*(uy(i,ny-1,k)-uy(i,ny-3,k)) - enddo - do concurrent (i=1:nx) - ty(i,ny,k) = zero - enddo - enddo - - ! Solve tri-diagonal system - call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) - - endif - endif - - if (istret /= 0) then - do concurrent (k=1:nz, j=1:ny, i=1:nx) - ty(i,j,k) = ty(i,j,k) * ppy(j) - enddo - endif - -end subroutine derypv + subroutine derypv(ty, uy, x3dop, ppy, nx, nym, ny, nz) + + USE x3d_operator_y_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nym, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: ty + real(mytype), intent(in), dimension(nx, nym, nz) :: uy + real(mytype), intent(in), dimension(ny) :: ppy + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (ncly) then + ! nym = ny + do concurrent(k=1:nz) + + ! Compute r.h.s. + do concurrent(i=1:nx) + ty(i, 1, k) = aciy6*(uy(i, 1, k) - uy(i, ny, k)) & + + bciy6*(uy(i, 2, k) - uy(i, ny - 1, k)) + end do + do concurrent(i=1:nx) + ty(i, 2, k) = aciy6*(uy(i, 2, k) - uy(i, 1, k)) & + + bciy6*(uy(i, 3, k) - uy(i, ny, k)) + end do + do concurrent(j=3:ny - 2, i=1:nx) + ty(i, j, k) = aciy6*(uy(i, j, k) - uy(i, j - 1, k)) & + + bciy6*(uy(i, j + 1, k) - uy(i, j - 2, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = aciy6*(uy(i, ny - 1, k) - uy(i, ny - 2, k)) & + + bciy6*(uy(i, ny, k) - uy(i, ny - 3, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = aciy6*(uy(i, ny, k) - uy(i, ny - 1, k)) & + + bciy6*(uy(i, 1, k) - uy(i, ny - 2, k)) + end do + end do + + ! Solve tri-diagonal system + call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nym = ny-1 + if (x3dop%npaire == 1) then + do concurrent(k=1:nz) + + ! Compute r.h.s. + do concurrent(i=1:nx) + ty(i, 1, k) = zero + end do + do concurrent(i=1:nx) + ty(i, 2, k) = aciy6*(uy(i, 2, k) - uy(i, 1, k)) & + + bciy6*(uy(i, 3, k) - uy(i, 1, k)) + end do + do concurrent(j=3:ny - 2, i=1:nx) + ty(i, j, k) = aciy6*(uy(i, j, k) - uy(i, j - 1, k)) & + + bciy6*(uy(i, j + 1, k) - uy(i, j - 2, k)) + end do + do concurrent(i=1:nx) + ty(i, ny - 1, k) = aciy6*(uy(i, ny - 1, k) - uy(i, ny - 2, k)) & + + bciy6*(uy(i, ny - 1, k) - uy(i, ny - 3, k)) + end do + do concurrent(i=1:nx) + ty(i, ny, k) = zero + end do + end do + + ! Solve tri-diagonal system + call ythomas(ty, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) + + end if + end if + + if (istret /= 0) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + ty(i, j, k) = ty(i, j, k)*ppy(j) + end do + end if + + end subroutine derypv !******************************************************************** ! -subroutine derzvp(tz,uz,x3dop,nx,ny,nz,nzm) - - USE x3d_operator_z_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz, nzm - real(mytype), intent(out), dimension(nx,ny,nzm) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (nz==1) then - do concurrent(k=1:nz, j=1:ny, i=1:nx) - tz(i,j,k) = zero - enddo - return - endif - - if (nclz) then - ! nzm = nz - - ! Compute r.h.s. - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = aciz6*(uz(i,j,2)-uz(i,j,1)) & - + bciz6*(uz(i,j,3)-uz(i,j,nz)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = aciz6*(uz(i,j,3)-uz(i,j,2)) & - + bciz6*(uz(i,j,4)-uz(i,j,1)) - enddo - do concurrent (k=3:nz-2, j=1:ny, i=1:nx) - tz(i,j,k) = aciz6*(uz(i,j,k+1)-uz(i,j,k)) & - + bciz6*(uz(i,j,k+2)-uz(i,j,k-1)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = aciz6*(uz(i,j,nz)-uz(i,j,nz-1)) & - + bciz6*(uz(i,j,1)-uz(i,j,nz-2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz ) = aciz6*(uz(i,j,1)-uz(i,j,nz)) & - + bciz6*(uz(i,j,2)-uz(i,j,nz-1)) - enddo - - ! Solve tri-diagonal system - call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nzm = nz-1 - - ! Compute r.h.s. - if (x3dop%npaire==1) then - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = aciz6*(uz(i,j,2)-uz(i,j,1)) & - + bciz6*(uz(i,j,3)-uz(i,j,2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = aciz6*(uz(i,j,3)-uz(i,j,2))& - + bciz6*(uz(i,j,4)-uz(i,j,1)) - enddo - else - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = aciz6*(uz(i,j,2)-uz(i,j,1)) & - + bciz6*(uz(i,j,3)-two*uz(i,j,1)+uz(i,j,2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = aciz6*(uz(i,j,3)-uz(i,j,2)) & - + bciz6*(uz(i,j,4)-uz(i,j,1)) - enddo - endif - do concurrent (k=3:nzm-2, j=1:ny, i=1:nx) - tz(i,j,k) = aciz6*(uz(i,j,k+1)-uz(i,j,k)) & - + bciz6*(uz(i,j,k+2)-uz(i,j,k-1)) - enddo - if (x3dop%npaire==1) then - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nzm-1) = aciz6*(uz(i,j,nzm)-uz(i,j,nzm-1)) & - + bciz6*(uz(i,j,nz)-uz(i,j,nzm-2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nzm ) = aciz6*(uz(i,j,nz)-uz(i,j,nzm)) & - + bciz6*(uz(i,j,nzm)-uz(i,j,nzm-1)) - enddo - else - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nzm-1) = aciz6*(uz(i,j,nz-1)-uz(i,j,nz-2)) & - + bciz6*(uz(i,j,nz)-uz(i,j,nz-3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nzm ) = aciz6*(uz(i,j,nz)-uz(i,j,nz-1)) & - + bciz6*(two*uz(i,j,nz)-uz(i,j,nz-1)-uz(i,j,nz-2)) - enddo - endif - - ! Solve tri-diagonal system - call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nzm) - - endif - -end subroutine derzvp + subroutine derzvp(tz, uz, x3dop, nx, ny, nz, nzm) + + USE x3d_operator_z_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz, nzm + real(mytype), intent(out), dimension(nx, ny, nzm) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (nz == 1) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + tz(i, j, k) = zero + end do + return + end if + + if (nclz) then + ! nzm = nz + + ! Compute r.h.s. + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = aciz6*(uz(i, j, 2) - uz(i, j, 1)) & + + bciz6*(uz(i, j, 3) - uz(i, j, nz)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = aciz6*(uz(i, j, 3) - uz(i, j, 2)) & + + bciz6*(uz(i, j, 4) - uz(i, j, 1)) + end do + do concurrent(k=3:nz - 2, j=1:ny, i=1:nx) + tz(i, j, k) = aciz6*(uz(i, j, k + 1) - uz(i, j, k)) & + + bciz6*(uz(i, j, k + 2) - uz(i, j, k - 1)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = aciz6*(uz(i, j, nz) - uz(i, j, nz - 1)) & + + bciz6*(uz(i, j, 1) - uz(i, j, nz - 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = aciz6*(uz(i, j, 1) - uz(i, j, nz)) & + + bciz6*(uz(i, j, 2) - uz(i, j, nz - 1)) + end do + + ! Solve tri-diagonal system + call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nzm = nz-1 + + ! Compute r.h.s. + if (x3dop%npaire == 1) then + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = aciz6*(uz(i, j, 2) - uz(i, j, 1)) & + + bciz6*(uz(i, j, 3) - uz(i, j, 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = aciz6*(uz(i, j, 3) - uz(i, j, 2)) & + + bciz6*(uz(i, j, 4) - uz(i, j, 1)) + end do + else + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = aciz6*(uz(i, j, 2) - uz(i, j, 1)) & + + bciz6*(uz(i, j, 3) - two*uz(i, j, 1) + uz(i, j, 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = aciz6*(uz(i, j, 3) - uz(i, j, 2)) & + + bciz6*(uz(i, j, 4) - uz(i, j, 1)) + end do + end if + do concurrent(k=3:nzm - 2, j=1:ny, i=1:nx) + tz(i, j, k) = aciz6*(uz(i, j, k + 1) - uz(i, j, k)) & + + bciz6*(uz(i, j, k + 2) - uz(i, j, k - 1)) + end do + if (x3dop%npaire == 1) then + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nzm - 1) = aciz6*(uz(i, j, nzm) - uz(i, j, nzm - 1)) & + + bciz6*(uz(i, j, nz) - uz(i, j, nzm - 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nzm) = aciz6*(uz(i, j, nz) - uz(i, j, nzm)) & + + bciz6*(uz(i, j, nzm) - uz(i, j, nzm - 1)) + end do + else + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nzm - 1) = aciz6*(uz(i, j, nz - 1) - uz(i, j, nz - 2)) & + + bciz6*(uz(i, j, nz) - uz(i, j, nz - 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nzm) = aciz6*(uz(i, j, nz) - uz(i, j, nz - 1)) & + + bciz6*(two*uz(i, j, nz) - uz(i, j, nz - 1) - uz(i, j, nz - 2)) + end do + end if + + ! Solve tri-diagonal system + call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nzm) + + end if + + end subroutine derzvp !******************************************************************** ! -subroutine interzvp(tz,uz,x3dop,nx,ny,nz,nzm) - - USE x3d_operator_z_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz, nzm - real(mytype), intent(out), dimension(nx,ny,nzm) :: tz - real(mytype), intent(in), dimension(nx,ny,nz) :: uz - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (nz==1) then - do concurrent(k=1:nz, j=1:ny, i=1:nx) - tz(i,j,k) = uz(i,j,k) - enddo - return - endif - - if (nclz) then - ! nzm = nz - - ! Compute r.h.s. - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = aiciz6*(uz(i,j,2)+uz(i,j,1)) & - + biciz6*(uz(i,j,3)+uz(i,j,nz)) & - + ciciz6*(uz(i,j,4)+uz(i,j,nz-1)) & - + diciz6*(uz(i,j,5)+uz(i,j,nz-2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = aiciz6*(uz(i,j,3)+uz(i,j,2)) & - + biciz6*(uz(i,j,4)+uz(i,j,1)) & - + ciciz6*(uz(i,j,5)+uz(i,j,nz)) & - + diciz6*(uz(i,j,6)+uz(i,j,nz-1)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,3) = aiciz6*(uz(i,j,4)+uz(i,j,3)) & - + biciz6*(uz(i,j,5)+uz(i,j,2)) & - + ciciz6*(uz(i,j,6)+uz(i,j,1)) & - + diciz6*(uz(i,j,7)+uz(i,j,nz)) - enddo - do concurrent (k=4:nz-4, j=1:ny, i=1:nx) - tz(i,j,k) = aiciz6*(uz(i,j,k+1)+uz(i,j,k)) & - + biciz6*(uz(i,j,k+2)+uz(i,j,k-1)) & - + ciciz6*(uz(i,j,k+3)+uz(i,j,k-2)) & - + diciz6*(uz(i,j,k+4)+uz(i,j,k-3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-3) = aiciz6*(uz(i,j,nz-2)+uz(i,j,nz-3)) & - + biciz6*(uz(i,j,nz-1)+uz(i,j,nz-4)) & - + ciciz6*(uz(i,j,nz)+uz(i,j,nz-5)) & - + diciz6*(uz(i,j,1)+uz(i,j,nz-6)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-2) = aiciz6*(uz(i,j,nz-1)+uz(i,j,nz-2)) & - + biciz6*(uz(i,j,nz)+uz(i,j,nz-3)) & - + ciciz6*(uz(i,j,1)+uz(i,j,nz-4)) & - + diciz6*(uz(i,j,2)+uz(i,j,nz-5)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = aiciz6*(uz(i,j,nz)+uz(i,j,nz-1)) & - + biciz6*(uz(i,j,1)+uz(i,j,nz-2)) & - + ciciz6*(uz(i,j,2)+uz(i,j,nz-3)) & - + diciz6*(uz(i,j,3)+uz(i,j,nz-4)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz ) = aiciz6*(uz(i,j,1)+uz(i,j,nz)) & - + biciz6*(uz(i,j,2)+uz(i,j,nz-1)) & - + ciciz6*(uz(i,j,3)+uz(i,j,nz-2)) & - + diciz6*(uz(i,j,4)+uz(i,j,nz-3)) - enddo - - ! Solve tri-diagonal system - call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nzm = nz-1 - if (x3dop%npaire==1) then - - ! Compute r.h.s. - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = aiciz6*(uz(i,j,2)+uz(i,j,1)) & - + biciz6*(uz(i,j,3)+uz(i,j,2)) & - + ciciz6*(uz(i,j,4)+uz(i,j,3)) & - + diciz6*(uz(i,j,5)+uz(i,j,4)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = aiciz6*(uz(i,j,3)+uz(i,j,2)) & - + biciz6*(uz(i,j,4)+uz(i,j,1)) & - + ciciz6*(uz(i,j,5)+uz(i,j,2)) & - + diciz6*(uz(i,j,6)+uz(i,j,3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,3) = aiciz6*(uz(i,j,4)+uz(i,j,3)) & - + biciz6*(uz(i,j,5)+uz(i,j,2)) & - + ciciz6*(uz(i,j,6)+uz(i,j,1)) & - + diciz6*(uz(i,j,7)+uz(i,j,2)) - enddo - do concurrent (k=4:nzm-3, j=1:ny, i=1:nx) - tz(i,j,k) = aiciz6*(uz(i,j,k+1)+uz(i,j,k)) & - + biciz6*(uz(i,j,k+2)+uz(i,j,k-1)) & - + ciciz6*(uz(i,j,k+3)+uz(i,j,k-2)) & - + diciz6*(uz(i,j,k+4)+uz(i,j,k-3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nzm-2) = aiciz6*(uz(i,j,nzm-1)+uz(i,j,nzm-2)) & - + biciz6*(uz(i,j,nzm)+uz(i,j,nzm-3)) & - + ciciz6*(uz(i,j,nz)+uz(i,j,nzm-4)) & - + diciz6*(uz(i,j,nzm)+uz(i,j,nzm-5)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nzm-1) = aiciz6*(uz(i,j,nzm)+uz(i,j,nzm-1)) & - + biciz6*(uz(i,j,nz)+uz(i,j,nzm-2)) & - + ciciz6*(uz(i,j,nzm)+uz(i,j,nzm-3)) & - + diciz6*(uz(i,j,nzm-1)+uz(i,j,nzm-4)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nzm) = aiciz6*(uz(i,j,nz)+uz(i,j,nzm)) & - + biciz6*(uz(i,j,nzm)+uz(i,j,nzm-1)) & - + ciciz6*(uz(i,j,nzm-1)+uz(i,j,nzm-2)) & - + diciz6*(uz(i,j,nzm-2)+uz(i,j,nzm-3)) - enddo - - ! Solve tri-diagonal system - call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nzm) - - endif - endif - -end subroutine interzvp + subroutine interzvp(tz, uz, x3dop, nx, ny, nz, nzm) + + USE x3d_operator_z_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz, nzm + real(mytype), intent(out), dimension(nx, ny, nzm) :: tz + real(mytype), intent(in), dimension(nx, ny, nz) :: uz + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (nz == 1) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + tz(i, j, k) = uz(i, j, k) + end do + return + end if + + if (nclz) then + ! nzm = nz + + ! Compute r.h.s. + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = aiciz6*(uz(i, j, 2) + uz(i, j, 1)) & + + biciz6*(uz(i, j, 3) + uz(i, j, nz)) & + + ciciz6*(uz(i, j, 4) + uz(i, j, nz - 1)) & + + diciz6*(uz(i, j, 5) + uz(i, j, nz - 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = aiciz6*(uz(i, j, 3) + uz(i, j, 2)) & + + biciz6*(uz(i, j, 4) + uz(i, j, 1)) & + + ciciz6*(uz(i, j, 5) + uz(i, j, nz)) & + + diciz6*(uz(i, j, 6) + uz(i, j, nz - 1)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 3) = aiciz6*(uz(i, j, 4) + uz(i, j, 3)) & + + biciz6*(uz(i, j, 5) + uz(i, j, 2)) & + + ciciz6*(uz(i, j, 6) + uz(i, j, 1)) & + + diciz6*(uz(i, j, 7) + uz(i, j, nz)) + end do + do concurrent(k=4:nz - 4, j=1:ny, i=1:nx) + tz(i, j, k) = aiciz6*(uz(i, j, k + 1) + uz(i, j, k)) & + + biciz6*(uz(i, j, k + 2) + uz(i, j, k - 1)) & + + ciciz6*(uz(i, j, k + 3) + uz(i, j, k - 2)) & + + diciz6*(uz(i, j, k + 4) + uz(i, j, k - 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 3) = aiciz6*(uz(i, j, nz - 2) + uz(i, j, nz - 3)) & + + biciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 4)) & + + ciciz6*(uz(i, j, nz) + uz(i, j, nz - 5)) & + + diciz6*(uz(i, j, 1) + uz(i, j, nz - 6)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 2) = aiciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 2)) & + + biciz6*(uz(i, j, nz) + uz(i, j, nz - 3)) & + + ciciz6*(uz(i, j, 1) + uz(i, j, nz - 4)) & + + diciz6*(uz(i, j, 2) + uz(i, j, nz - 5)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = aiciz6*(uz(i, j, nz) + uz(i, j, nz - 1)) & + + biciz6*(uz(i, j, 1) + uz(i, j, nz - 2)) & + + ciciz6*(uz(i, j, 2) + uz(i, j, nz - 3)) & + + diciz6*(uz(i, j, 3) + uz(i, j, nz - 4)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = aiciz6*(uz(i, j, 1) + uz(i, j, nz)) & + + biciz6*(uz(i, j, 2) + uz(i, j, nz - 1)) & + + ciciz6*(uz(i, j, 3) + uz(i, j, nz - 2)) & + + diciz6*(uz(i, j, 4) + uz(i, j, nz - 3)) + end do + + ! Solve tri-diagonal system + call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nzm = nz-1 + if (x3dop%npaire == 1) then + + ! Compute r.h.s. + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = aiciz6*(uz(i, j, 2) + uz(i, j, 1)) & + + biciz6*(uz(i, j, 3) + uz(i, j, 2)) & + + ciciz6*(uz(i, j, 4) + uz(i, j, 3)) & + + diciz6*(uz(i, j, 5) + uz(i, j, 4)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = aiciz6*(uz(i, j, 3) + uz(i, j, 2)) & + + biciz6*(uz(i, j, 4) + uz(i, j, 1)) & + + ciciz6*(uz(i, j, 5) + uz(i, j, 2)) & + + diciz6*(uz(i, j, 6) + uz(i, j, 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 3) = aiciz6*(uz(i, j, 4) + uz(i, j, 3)) & + + biciz6*(uz(i, j, 5) + uz(i, j, 2)) & + + ciciz6*(uz(i, j, 6) + uz(i, j, 1)) & + + diciz6*(uz(i, j, 7) + uz(i, j, 2)) + end do + do concurrent(k=4:nzm - 3, j=1:ny, i=1:nx) + tz(i, j, k) = aiciz6*(uz(i, j, k + 1) + uz(i, j, k)) & + + biciz6*(uz(i, j, k + 2) + uz(i, j, k - 1)) & + + ciciz6*(uz(i, j, k + 3) + uz(i, j, k - 2)) & + + diciz6*(uz(i, j, k + 4) + uz(i, j, k - 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nzm - 2) = aiciz6*(uz(i, j, nzm - 1) + uz(i, j, nzm - 2)) & + + biciz6*(uz(i, j, nzm) + uz(i, j, nzm - 3)) & + + ciciz6*(uz(i, j, nz) + uz(i, j, nzm - 4)) & + + diciz6*(uz(i, j, nzm) + uz(i, j, nzm - 5)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nzm - 1) = aiciz6*(uz(i, j, nzm) + uz(i, j, nzm - 1)) & + + biciz6*(uz(i, j, nz) + uz(i, j, nzm - 2)) & + + ciciz6*(uz(i, j, nzm) + uz(i, j, nzm - 3)) & + + diciz6*(uz(i, j, nzm - 1) + uz(i, j, nzm - 4)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nzm) = aiciz6*(uz(i, j, nz) + uz(i, j, nzm)) & + + biciz6*(uz(i, j, nzm) + uz(i, j, nzm - 1)) & + + ciciz6*(uz(i, j, nzm - 1) + uz(i, j, nzm - 2)) & + + diciz6*(uz(i, j, nzm - 2) + uz(i, j, nzm - 3)) + end do + + ! Solve tri-diagonal system + call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nzm) + + end if + end if + + end subroutine interzvp !******************************************************************** ! -subroutine derzpv(tz,uz,x3dop,nx,ny,nzm,nz) - - USE x3d_operator_z_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, nzm, ny, nz - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nzm) :: uz - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (nz==1) then - do concurrent(k=1:nz, j=1:ny, i=1:nx) - tz(i,j,k) = zero - enddo - return - endif - - if (nclz) then - ! nzm = nz - - ! Compute r.h.s. - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = aciz6*(uz(i,j,1)-uz(i,j,nz)) & - + bciz6*(uz(i,j,2)-uz(i,j,nz-1)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = aciz6*(uz(i,j,2)-uz(i,j,1)) & - + bciz6*(uz(i,j,3)-uz(i,j,nz)) - enddo - do concurrent (k=3:nz-2, j=1:ny, i=1:nx) - tz(i,j,k) = aciz6*(uz(i,j,k)-uz(i,j,k-1)) & - + bciz6*(uz(i,j,k+1)-uz(i,j,k-2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = aciz6*(uz(i,j,nz-1)-uz(i,j,nz-2)) & - + bciz6*(uz(i,j,nz)-uz(i,j,nz-3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz) = aciz6*(uz(i,j,nz)-uz(i,j,nz-1)) & - + bciz6*(uz(i,j,1)-uz(i,j,nz-2)) - enddo - - ! Solve tri-diagonal system - call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nzm = nz-1 - if (x3dop%npaire==1) then - - ! Compute r.h.s. - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = zero - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = aciz6*(uz(i,j,2)-uz(i,j,1)) & - + bciz6*(uz(i,j,3)-uz(i,j,1)) - enddo - do concurrent (k=3:nz-2, j=1:ny, i=1:nx) - tz(i,j,k) = aciz6*(uz(i,j,k)-uz(i,j,k-1)) & - + bciz6*(uz(i,j,k+1)-uz(i,j,k-2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = aciz6*(uz(i,j,nz-1)-uz(i,j,nz-2)) & - + bciz6*(uz(i,j,nz-1)-uz(i,j,nz-3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz) = zero - enddo - - ! Solve tri-diagonal system - call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) - - endif - endif - -end subroutine derzpv + subroutine derzpv(tz, uz, x3dop, nx, ny, nzm, nz) + + USE x3d_operator_z_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, nzm, ny, nz + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nzm) :: uz + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (nz == 1) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + tz(i, j, k) = zero + end do + return + end if + + if (nclz) then + ! nzm = nz + + ! Compute r.h.s. + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = aciz6*(uz(i, j, 1) - uz(i, j, nz)) & + + bciz6*(uz(i, j, 2) - uz(i, j, nz - 1)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = aciz6*(uz(i, j, 2) - uz(i, j, 1)) & + + bciz6*(uz(i, j, 3) - uz(i, j, nz)) + end do + do concurrent(k=3:nz - 2, j=1:ny, i=1:nx) + tz(i, j, k) = aciz6*(uz(i, j, k) - uz(i, j, k - 1)) & + + bciz6*(uz(i, j, k + 1) - uz(i, j, k - 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = aciz6*(uz(i, j, nz - 1) - uz(i, j, nz - 2)) & + + bciz6*(uz(i, j, nz) - uz(i, j, nz - 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = aciz6*(uz(i, j, nz) - uz(i, j, nz - 1)) & + + bciz6*(uz(i, j, 1) - uz(i, j, nz - 2)) + end do + + ! Solve tri-diagonal system + call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nzm = nz-1 + if (x3dop%npaire == 1) then + + ! Compute r.h.s. + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = zero + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = aciz6*(uz(i, j, 2) - uz(i, j, 1)) & + + bciz6*(uz(i, j, 3) - uz(i, j, 1)) + end do + do concurrent(k=3:nz - 2, j=1:ny, i=1:nx) + tz(i, j, k) = aciz6*(uz(i, j, k) - uz(i, j, k - 1)) & + + bciz6*(uz(i, j, k + 1) - uz(i, j, k - 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = aciz6*(uz(i, j, nz - 1) - uz(i, j, nz - 2)) & + + bciz6*(uz(i, j, nz - 1) - uz(i, j, nz - 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = zero + end do + + ! Solve tri-diagonal system + call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) + + end if + end if + + end subroutine derzpv !******************************************************************** ! -subroutine interzpv(tz,uz,x3dop,nx,ny,nzm,nz) - - USE x3d_operator_z_data - - implicit none - - ! Arguments - integer, intent(in) :: nx, ny, nz, nzm - real(mytype), intent(out), dimension(nx,ny,nz) :: tz - real(mytype), intent(in), dimension(nx,ny,nzm) :: uz - type(x3doperator1d), intent(in) :: x3dop - - ! Local variables - integer :: i, j, k - - if (nz==1) then - do concurrent(k=1:nz, j=1:ny, i=1:nx) - tz(i,j,k) = uz(i,j,k) - enddo - return - endif - - if (nclz) then - ! nzm = nz - - ! Compute r.h.s. - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = aiciz6*(uz(i,j,1)+uz(i,j,nz)) & - + biciz6*(uz(i,j,2)+uz(i,j,nz-1)) & - + ciciz6*(uz(i,j,3)+uz(i,j,nz-2)) & - + diciz6*(uz(i,j,4)+uz(i,j,nz-3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = aiciz6*(uz(i,j,2)+uz(i,j,1)) & - + biciz6*(uz(i,j,3)+uz(i,j,nz)) & - + ciciz6*(uz(i,j,4)+uz(i,j,nz-1)) & - + diciz6*(uz(i,j,5)+uz(i,j,nz-2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,3) = aiciz6*(uz(i,j,3)+uz(i,j,2)) & - + biciz6*(uz(i,j,4)+uz(i,j,1)) & - + ciciz6*(uz(i,j,5)+uz(i,j,nz)) & - + diciz6*(uz(i,j,6)+uz(i,j,nz-1)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,4) = aiciz6*(uz(i,j,4)+uz(i,j,3)) & - + biciz6*(uz(i,j,5)+uz(i,j,2)) & - + ciciz6*(uz(i,j,6)+uz(i,j,1)) & - + diciz6*(uz(i,j,7)+uz(i,j,nz)) - enddo - do concurrent (k=5:nz-3, j=1:ny, i=1:nx) - tz(i,j,k) = aiciz6*(uz(i,j,k)+uz(i,j,k-1)) & - + biciz6*(uz(i,j,k+1)+uz(i,j,k-2)) & - + ciciz6*(uz(i,j,k+2)+uz(i,j,k-3)) & - + diciz6*(uz(i,j,k+3)+uz(i,j,k-4)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-2) = aiciz6*(uz(i,j,nz-2)+uz(i,j,nz-3)) & - + biciz6*(uz(i,j,nz-1)+uz(i,j,nz-4)) & - + ciciz6*(uz(i,j,nz)+uz(i,j,nz-5)) & - + diciz6*(uz(i,j,1)+uz(i,j,nz-6)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = aiciz6*(uz(i,j,nz-1)+uz(i,j,nz-2)) & - + biciz6*(uz(i,j,nz)+uz(i,j,nz-3)) & - + ciciz6*(uz(i,j,1)+uz(i,j,nz-4)) & - + diciz6*(uz(i,j,2)+uz(i,j,nz-5)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz ) = aiciz6*(uz(i,j,nz)+uz(i,j,nz-1)) & - + biciz6*(uz(i,j,1)+uz(i,j,nz-2)) & - + ciciz6*(uz(i,j,2)+uz(i,j,nz-3)) & - + diciz6*(uz(i,j,3)+uz(i,j,nz-4)) - enddo - - ! Solve tri-diagonal system - call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) - - else - ! nzm = nz-1 - if (x3dop%npaire==1) then - - ! Compute r.h.s. - do concurrent (j=1:ny, i=1:nx) - tz(i,j,1) = aiciz6*(uz(i,j,1)+uz(i,j,1)) & - + biciz6*(uz(i,j,2)+uz(i,j,2)) & - + ciciz6*(uz(i,j,3)+uz(i,j,3)) & - + diciz6*(uz(i,j,4)+uz(i,j,4)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,2) = aiciz6*(uz(i,j,2)+uz(i,j,1)) & - + biciz6*(uz(i,j,3)+uz(i,j,1))& - + ciciz6*(uz(i,j,4)+uz(i,j,2))& - + diciz6*(uz(i,j,5)+uz(i,j,3)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,3) = aiciz6*(uz(i,j,3)+uz(i,j,2)) & - + biciz6*(uz(i,j,4)+uz(i,j,1)) & - + ciciz6*(uz(i,j,5)+uz(i,j,1)) & - + diciz6*(uz(i,j,6)+uz(i,j,2)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,4) = aiciz6*(uz(i,j,4)+uz(i,j,3)) & - + biciz6*(uz(i,j,5)+uz(i,j,2)) & - + ciciz6*(uz(i,j,6)+uz(i,j,1)) & - + diciz6*(uz(i,j,7)+uz(i,j,1)) - enddo - do concurrent (k=5:nz-4, j=1:ny, i=1:nx) - tz(i,j,k) = aiciz6*(uz(i,j,k)+uz(i,j,k-1)) & - + biciz6*(uz(i,j,k+1)+uz(i,j,k-2)) & - + ciciz6*(uz(i,j,k+2)+uz(i,j,k-3)) & - + diciz6*(uz(i,j,k+3)+uz(i,j,k-4)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-3) = aiciz6*(uz(i,j,nz-3)+uz(i,j,nz-4)) & - + biciz6*(uz(i,j,nz-2)+uz(i,j,nz-5)) & - + ciciz6*(uz(i,j,nz-1)+uz(i,j,nz-6)) & - + diciz6*(uz(i,j,nz-1)+uz(i,j,nz-7)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-2) = aiciz6*(uz(i,j,nz-2)+uz(i,j,nz-3)) & - + biciz6*(uz(i,j,nz-1)+uz(i,j,nz-4)) & - + ciciz6*(uz(i,j,nz-1)+uz(i,j,nz-5)) & - + diciz6*(uz(i,j,nz-2)+uz(i,j,nz-6)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz-1) = aiciz6*(uz(i,j,nz-1)+uz(i,j,nz-2)) & - + biciz6*(uz(i,j,nz-1)+uz(i,j,nz-3)) & - + ciciz6*(uz(i,j,nz-2)+uz(i,j,nz-4)) & - + diciz6*(uz(i,j,nz-3)+uz(i,j,nz-5)) - enddo - do concurrent (j=1:ny, i=1:nx) - tz(i,j,nz ) = aiciz6*(uz(i,j,nz-1)+uz(i,j,nz-1)) & - + biciz6*(uz(i,j,nz-2)+uz(i,j,nz-2)) & - + ciciz6*(uz(i,j,nz-3)+uz(i,j,nz-3)) & - + diciz6*(uz(i,j,nz-4)+uz(i,j,nz-4)) - enddo - - ! Solve tri-diagonal system - call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) - - endif - endif - -end subroutine interzpv + subroutine interzpv(tz, uz, x3dop, nx, ny, nzm, nz) + + USE x3d_operator_z_data + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny, nz, nzm + real(mytype), intent(out), dimension(nx, ny, nz) :: tz + real(mytype), intent(in), dimension(nx, ny, nzm) :: uz + type(x3doperator1d), intent(in) :: x3dop + + ! Local variables + integer :: i, j, k + + if (nz == 1) then + do concurrent(k=1:nz, j=1:ny, i=1:nx) + tz(i, j, k) = uz(i, j, k) + end do + return + end if + + if (nclz) then + ! nzm = nz + + ! Compute r.h.s. + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = aiciz6*(uz(i, j, 1) + uz(i, j, nz)) & + + biciz6*(uz(i, j, 2) + uz(i, j, nz - 1)) & + + ciciz6*(uz(i, j, 3) + uz(i, j, nz - 2)) & + + diciz6*(uz(i, j, 4) + uz(i, j, nz - 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = aiciz6*(uz(i, j, 2) + uz(i, j, 1)) & + + biciz6*(uz(i, j, 3) + uz(i, j, nz)) & + + ciciz6*(uz(i, j, 4) + uz(i, j, nz - 1)) & + + diciz6*(uz(i, j, 5) + uz(i, j, nz - 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 3) = aiciz6*(uz(i, j, 3) + uz(i, j, 2)) & + + biciz6*(uz(i, j, 4) + uz(i, j, 1)) & + + ciciz6*(uz(i, j, 5) + uz(i, j, nz)) & + + diciz6*(uz(i, j, 6) + uz(i, j, nz - 1)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 4) = aiciz6*(uz(i, j, 4) + uz(i, j, 3)) & + + biciz6*(uz(i, j, 5) + uz(i, j, 2)) & + + ciciz6*(uz(i, j, 6) + uz(i, j, 1)) & + + diciz6*(uz(i, j, 7) + uz(i, j, nz)) + end do + do concurrent(k=5:nz - 3, j=1:ny, i=1:nx) + tz(i, j, k) = aiciz6*(uz(i, j, k) + uz(i, j, k - 1)) & + + biciz6*(uz(i, j, k + 1) + uz(i, j, k - 2)) & + + ciciz6*(uz(i, j, k + 2) + uz(i, j, k - 3)) & + + diciz6*(uz(i, j, k + 3) + uz(i, j, k - 4)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 2) = aiciz6*(uz(i, j, nz - 2) + uz(i, j, nz - 3)) & + + biciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 4)) & + + ciciz6*(uz(i, j, nz) + uz(i, j, nz - 5)) & + + diciz6*(uz(i, j, 1) + uz(i, j, nz - 6)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = aiciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 2)) & + + biciz6*(uz(i, j, nz) + uz(i, j, nz - 3)) & + + ciciz6*(uz(i, j, 1) + uz(i, j, nz - 4)) & + + diciz6*(uz(i, j, 2) + uz(i, j, nz - 5)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = aiciz6*(uz(i, j, nz) + uz(i, j, nz - 1)) & + + biciz6*(uz(i, j, 1) + uz(i, j, nz - 2)) & + + ciciz6*(uz(i, j, 2) + uz(i, j, nz - 3)) & + + diciz6*(uz(i, j, 3) + uz(i, j, nz - 4)) + end do + + ! Solve tri-diagonal system + call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, x3dop%periodic, x3dop%alfa, nx, ny, nz) + + else + ! nzm = nz-1 + if (x3dop%npaire == 1) then + + ! Compute r.h.s. + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 1) = aiciz6*(uz(i, j, 1) + uz(i, j, 1)) & + + biciz6*(uz(i, j, 2) + uz(i, j, 2)) & + + ciciz6*(uz(i, j, 3) + uz(i, j, 3)) & + + diciz6*(uz(i, j, 4) + uz(i, j, 4)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 2) = aiciz6*(uz(i, j, 2) + uz(i, j, 1)) & + + biciz6*(uz(i, j, 3) + uz(i, j, 1)) & + + ciciz6*(uz(i, j, 4) + uz(i, j, 2)) & + + diciz6*(uz(i, j, 5) + uz(i, j, 3)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 3) = aiciz6*(uz(i, j, 3) + uz(i, j, 2)) & + + biciz6*(uz(i, j, 4) + uz(i, j, 1)) & + + ciciz6*(uz(i, j, 5) + uz(i, j, 1)) & + + diciz6*(uz(i, j, 6) + uz(i, j, 2)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, 4) = aiciz6*(uz(i, j, 4) + uz(i, j, 3)) & + + biciz6*(uz(i, j, 5) + uz(i, j, 2)) & + + ciciz6*(uz(i, j, 6) + uz(i, j, 1)) & + + diciz6*(uz(i, j, 7) + uz(i, j, 1)) + end do + do concurrent(k=5:nz - 4, j=1:ny, i=1:nx) + tz(i, j, k) = aiciz6*(uz(i, j, k) + uz(i, j, k - 1)) & + + biciz6*(uz(i, j, k + 1) + uz(i, j, k - 2)) & + + ciciz6*(uz(i, j, k + 2) + uz(i, j, k - 3)) & + + diciz6*(uz(i, j, k + 3) + uz(i, j, k - 4)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 3) = aiciz6*(uz(i, j, nz - 3) + uz(i, j, nz - 4)) & + + biciz6*(uz(i, j, nz - 2) + uz(i, j, nz - 5)) & + + ciciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 6)) & + + diciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 7)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 2) = aiciz6*(uz(i, j, nz - 2) + uz(i, j, nz - 3)) & + + biciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 4)) & + + ciciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 5)) & + + diciz6*(uz(i, j, nz - 2) + uz(i, j, nz - 6)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz - 1) = aiciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 2)) & + + biciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 3)) & + + ciciz6*(uz(i, j, nz - 2) + uz(i, j, nz - 4)) & + + diciz6*(uz(i, j, nz - 3) + uz(i, j, nz - 5)) + end do + do concurrent(j=1:ny, i=1:nx) + tz(i, j, nz) = aiciz6*(uz(i, j, nz - 1) + uz(i, j, nz - 1)) & + + biciz6*(uz(i, j, nz - 2) + uz(i, j, nz - 2)) & + + ciciz6*(uz(i, j, nz - 3) + uz(i, j, nz - 3)) & + + diciz6*(uz(i, j, nz - 4) + uz(i, j, nz - 4)) + end do + + ! Solve tri-diagonal system + call zthomas(tz, x3dop%f, x3dop%s, x3dop%w, nx, ny, nz) + + end if + end if + + end subroutine interzpv end module x3d_staggered diff --git a/src/x3d_tools.f90 b/src/x3d_tools.f90 index 7e1c77f..8757232 100644 --- a/src/x3d_tools.f90 +++ b/src/x3d_tools.f90 @@ -5,16 +5,16 @@ !################################################################## pure function rl(complexnumber) - use decomp_2d, only : mytype + use decomp_2d, only: mytype - implicit none + implicit none - !$acc routine seq + !$acc routine seq - real(mytype) :: rl - complex(mytype), intent(in) :: complexnumber + real(mytype) :: rl + complex(mytype), intent(in) :: complexnumber - rl = real(complexnumber, kind=mytype) + rl = real(complexnumber, kind=mytype) end function rl !################################################################## @@ -22,33 +22,33 @@ end function rl !################################################################## pure function iy(complexnumber) - use decomp_2d, only : mytype + use decomp_2d, only: mytype - implicit none + implicit none - !$acc routine seq + !$acc routine seq - real(mytype) :: iy - complex(mytype), intent(in) :: complexnumber + real(mytype) :: iy + complex(mytype), intent(in) :: complexnumber - iy = aimag(complexnumber) + iy = aimag(complexnumber) end function iy !################################################################## !################################################################## -pure function cx(realpart,imaginarypart) +pure function cx(realpart, imaginarypart) - use decomp_2d, only : mytype + use decomp_2d, only: mytype - implicit none + implicit none - !$acc routine seq + !$acc routine seq - complex(mytype) :: cx - real(mytype), intent(in) :: realpart, imaginarypart + complex(mytype) :: cx + real(mytype), intent(in) :: realpart, imaginarypart - cx = cmplx(realpart, imaginarypart, kind=mytype) + cx = cmplx(realpart, imaginarypart, kind=mytype) end function cx !################################################################################ @@ -56,170 +56,169 @@ end function cx !################################################################## subroutine boot_xcompact3d() - use MPI - use decomp_2d, only : nrank, nproc, decomp_2d_abort + use MPI + use decomp_2d, only: nrank, nproc, decomp_2d_abort - implicit none + implicit none - integer :: code + integer :: code - !! Initialise MPI - call MPI_INIT(code) - if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, "MPI_INIT") - call MPI_COMM_RANK(MPI_COMM_WORLD,nrank,code) - if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, "MPI_COMM_RANK") - call MPI_COMM_SIZE(MPI_COMM_WORLD,nproc,code) - if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, "MPI_COMM_SIZE") + ! Initialise MPI + call MPI_INIT(code) + if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, "MPI_INIT") + call MPI_COMM_RANK(MPI_COMM_WORLD, nrank, code) + if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, "MPI_COMM_RANK") + call MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, code) + if (code /= 0) call decomp_2d_abort(__FILE__, __LINE__, code, "MPI_COMM_SIZE") - -endsubroutine boot_xcompact3d +end subroutine boot_xcompact3d !######################################################################## !######################################################################## subroutine init_xcompact3d(ndt_max) - use decomp_2d, only : decomp_2d_init, decomp_info_init - use decomp_2d, only : init_coarser_mesh_statS, & + use decomp_2d, only: decomp_2d_init, decomp_info_init + use decomp_2d, only: init_coarser_mesh_statS, & init_coarser_mesh_statV, & init_coarser_mesh_statP - use decomp_2d, only : ph1, ph2, ph3, phG - USE decomp_2d_poisson, ONLY : decomp_2d_poisson_init - use x3d_operator_x_data, only : x3d_operator_x_data_init - use x3d_operator_y_data, only : x3d_operator_y_data_init - use x3d_operator_z_data, only : x3d_operator_z_data_init - use x3d_operator_1d, only : x3d_operator_1d_init - use x3d_derive, only : x3d_derive_init - use parameters - use case - - use var - - use variables, only : nx, ny, nz, nxm, nym, nzm - use variables, only : p_row, p_col - use variables, only : test_mode - use variables, only : nstat, nprobe, nvisu - - implicit none - - !real, intent(inout) :: trun - integer, intent(inout) :: ndt_max - - integer :: nargin, arg, FNLength, status, DecInd - logical :: back - character(len=80) :: InputFN, FNBase - - ! Handle input file like a boss -- GD - nargin=command_argument_count() - - !! Don't want to read input files - just basic numbers necessary for compute - ! 1) nx = 16 - ! 2) ny = 16 - ! 3) nz = 16 - ! 4) p_row = 0 - ! 5) p_col = 0 - nx = 32; ny = 32; nz = 32 - p_row = 0; p_col = 0 - !trun = 5.0 - ndt_max = 5 - test_mode = .false. - do arg = 1, nargin - call get_command_argument(arg, InputFN, FNLength, status) - read(InputFN, *, iostat=status) DecInd - if (arg.eq.1) then - nx = DecInd - elseif (arg.eq.2) then - ny = DecInd - elseif (arg.eq.3) then - nz = DecInd - elseif (arg.eq.4) then - p_row = DecInd - elseif (arg.eq.5) then - p_col = DecInd - elseif (arg.eq.6) then - !trun = real(DecInd) - ndt_max = DecInd - elseif (arg.eq.7) then - if (DecInd.eq.0) then - test_mode = .false. - else - test_mode = .true. - end if - write(*,*) 'Test mode ', test_mode - else - print *, "Error: Too many arguments!" - print *, " x3div accepts" - print *, " 1) nx (default=16)" - print *, " 2) ny (default=16)" - print *, " 3) nz (default=16)" - print *, " 4) p_row (default=0)" - print *, " 5) p_col (default=0)" - print *, " 6) ndt_max (default=10)" - print *, " 7) test_mode logical 0/1 (default=0)" - endif - enddo - - call parameter() - call case_boot() - call listing() - call case_listing() - - call decomp_2d_init(nx,ny,nz,p_row,p_col) - call init_coarser_mesh_statS(nstat,nstat,nstat,.true.) !start from 1 == true - call init_coarser_mesh_statV(nvisu,nvisu,nvisu,.true.) !start from 1 == true - call init_coarser_mesh_statP(nprobe,nprobe,nprobe,.true.) !start from 1 == true - !div: nx ny nz --> nxm ny nz --> nxm nym nz --> nxm nym nzm - call decomp_info_init(nxm, nym, nzm, ph1) - !gradp: nxm nym nzm -> nxm nym nz --> nxm ny nz --> nx ny nz - call decomp_info_init(nxm, ny, nz, ph2) - call decomp_info_init(nxm, nym, nz, ph3) - - call var_init() - call x3d_operator_x_data_init(nx, nxm) - call x3d_operator_y_data_init(ny, nym) - call x3d_operator_z_data_init(nz, nzm) - call x3d_operator_1d_init() - call x3d_derive_init() - - call decomp_2d_poisson_init() - call decomp_info_init(nxm,nym,nzm,phG) - -endsubroutine init_xcompact3d + use decomp_2d, only: ph1, ph2, ph3, phG + USE decomp_2d_poisson, ONLY: decomp_2d_poisson_init + use x3d_operator_x_data, only: x3d_operator_x_data_init + use x3d_operator_y_data, only: x3d_operator_y_data_init + use x3d_operator_z_data, only: x3d_operator_z_data_init + use x3d_operator_1d, only: x3d_operator_1d_init + use x3d_derive, only: x3d_derive_init + use parameters + use case + + use var + + use variables, only: nx, ny, nz, nxm, nym, nzm + use variables, only: p_row, p_col + use variables, only: test_mode + use variables, only: nstat, nprobe, nvisu + + implicit none + + !real, intent(inout) :: trun + integer, intent(inout) :: ndt_max + + integer :: nargin, arg, FNLength, status, DecInd + logical :: back + character(len=80) :: InputFN, FNBase + + ! Handle input file like a boss -- GD + nargin = command_argument_count() + + ! Don't want to read input files - just basic numbers necessary for compute + ! 1) nx = 16 + ! 2) ny = 16 + ! 3) nz = 16 + ! 4) p_row = 0 + ! 5) p_col = 0 + nx = 32; ny = 32; nz = 32 + p_row = 0; p_col = 0 + !trun = 5.0 + ndt_max = 5 + test_mode = .false. + do arg = 1, nargin + call get_command_argument(arg, InputFN, FNLength, status) + read (InputFN, *, iostat=status) DecInd + if (arg == 1) then + nx = DecInd + elseif (arg == 2) then + ny = DecInd + elseif (arg == 3) then + nz = DecInd + elseif (arg == 4) then + p_row = DecInd + elseif (arg == 5) then + p_col = DecInd + elseif (arg == 6) then + !trun = real(DecInd) + ndt_max = DecInd + elseif (arg == 7) then + if (DecInd == 0) then + test_mode = .false. + else + test_mode = .true. + end if + write (*, *) 'Test mode ', test_mode + else + print *, "Error: Too many arguments!" + print *, " x3div accepts" + print *, " 1) nx (default=16)" + print *, " 2) ny (default=16)" + print *, " 3) nz (default=16)" + print *, " 4) p_row (default=0)" + print *, " 5) p_col (default=0)" + print *, " 6) ndt_max (default=10)" + print *, " 7) test_mode logical 0/1 (default=0)" + end if + end do + + call parameter() + call case_boot() + call listing() + call case_listing() + + call decomp_2d_init(nx, ny, nz, p_row, p_col) + call init_coarser_mesh_statS(nstat, nstat, nstat, .true.) !start from 1 == true + call init_coarser_mesh_statV(nvisu, nvisu, nvisu, .true.) !start from 1 == true + call init_coarser_mesh_statP(nprobe, nprobe, nprobe, .true.) !start from 1 == true + !div: nx ny nz --> nxm ny nz --> nxm nym nz --> nxm nym nzm + call decomp_info_init(nxm, nym, nzm, ph1) + !gradp: nxm nym nzm -> nxm nym nz --> nxm ny nz --> nx ny nz + call decomp_info_init(nxm, ny, nz, ph2) + call decomp_info_init(nxm, nym, nz, ph3) + + call var_init() + call x3d_operator_x_data_init(nx, nxm) + call x3d_operator_y_data_init(ny, nym) + call x3d_operator_z_data_init(nz, nzm) + call x3d_operator_1d_init() + call x3d_derive_init() + + call decomp_2d_poisson_init() + call decomp_info_init(nxm, nym, nzm, phG) + +end subroutine init_xcompact3d !######################################################################## !######################################################################## subroutine finalise_xcompact3d(flag) - use MPI - use decomp_2d, only : decomp_2d_finalize, decomp_info_finalize, & + use MPI + use decomp_2d, only: decomp_2d_finalize, decomp_info_finalize, & ph1, ph2, ph3, phG - use decomp_2d_poisson, only : decomp_2d_poisson_finalize - use x3d_operator_x_data, only : x3d_operator_x_data_finalize - use x3d_operator_y_data, only : x3d_operator_y_data_finalize - use x3d_operator_z_data, only : x3d_operator_z_data_finalize - use x3d_operator_1d, only : x3d_operator_1d_finalize - use x3d_derive, only : x3d_derive_finalize - use var, only : var_finalize - - implicit none - - logical, intent(in) :: flag - integer :: ierr - - call decomp_info_finalize(ph1) - call decomp_info_finalize(ph2) - call decomp_info_finalize(ph3) - call decomp_info_finalize(phG) - call decomp_2d_poisson_finalize() - - call x3d_derive_finalize() - call x3d_operator_1d_finalize() - call x3d_operator_x_data_finalize() - call x3d_operator_y_data_finalize() - call x3d_operator_z_data_finalize() - call var_finalize() - - call decomp_2d_finalize() - if (flag) then - CALL MPI_FINALIZE(ierr) - endif - -endsubroutine finalise_xcompact3d + use decomp_2d_poisson, only: decomp_2d_poisson_finalize + use x3d_operator_x_data, only: x3d_operator_x_data_finalize + use x3d_operator_y_data, only: x3d_operator_y_data_finalize + use x3d_operator_z_data, only: x3d_operator_z_data_finalize + use x3d_operator_1d, only: x3d_operator_1d_finalize + use x3d_derive, only: x3d_derive_finalize + use var, only: var_finalize + + implicit none + + logical, intent(in) :: flag + integer :: ierr + + call decomp_info_finalize(ph1) + call decomp_info_finalize(ph2) + call decomp_info_finalize(ph3) + call decomp_info_finalize(phG) + call decomp_2d_poisson_finalize() + + call x3d_derive_finalize() + call x3d_operator_1d_finalize() + call x3d_operator_x_data_finalize() + call x3d_operator_y_data_finalize() + call x3d_operator_z_data_finalize() + call var_finalize() + + call decomp_2d_finalize() + if (flag) then + CALL MPI_FINALIZE(ierr) + end if + +end subroutine finalise_xcompact3d diff --git a/src/x3d_transpose.f90 b/src/x3d_transpose.f90 index e41599e..23c8eb7 100644 --- a/src/x3d_transpose.f90 +++ b/src/x3d_transpose.f90 @@ -4,381 +4,375 @@ module x3d_transpose - use decomp_2d, only : mytype, decomp_info, decomp_main - use variables, only : p_row, p_col + use decomp_2d, only: mytype, decomp_info, decomp_main + use variables, only: p_row, p_col - implicit none + implicit none - ! Make everything private unless declared public - private + ! Make everything private unless declared public + private - public :: x3d_transpose_x_to_y, & + public :: x3d_transpose_x_to_y, & x3d_transpose_y_to_z, & x3d_transpose_z_to_y, & x3d_transpose_y_to_x - interface x3d_transpose_x_to_y - module procedure x3d_transpose_x_to_y_real_short - module procedure x3d_transpose_x_to_y_real - module procedure x3d_transpose_x_to_y_cplx_short - module procedure x3d_transpose_x_to_y_cplx - end interface x3d_transpose_x_to_y - - interface x3d_transpose_y_to_z - module procedure x3d_transpose_y_to_z_real_short - module procedure x3d_transpose_y_to_z_real - module procedure x3d_transpose_y_to_z_cplx_short - module procedure x3d_transpose_y_to_z_cplx - end interface x3d_transpose_y_to_z - - interface x3d_transpose_z_to_y - module procedure x3d_transpose_z_to_y_real_short - module procedure x3d_transpose_z_to_y_real - module procedure x3d_transpose_z_to_y_cplx_short - module procedure x3d_transpose_z_to_y_cplx - end interface x3d_transpose_z_to_y - - interface x3d_transpose_y_to_x - module procedure x3d_transpose_y_to_x_real_short - module procedure x3d_transpose_y_to_x_real - module procedure x3d_transpose_y_to_x_cplx_short - module procedure x3d_transpose_y_to_x_cplx - end interface x3d_transpose_y_to_x - + interface x3d_transpose_x_to_y + module procedure x3d_transpose_x_to_y_real_short + module procedure x3d_transpose_x_to_y_real + module procedure x3d_transpose_x_to_y_cplx_short + module procedure x3d_transpose_x_to_y_cplx + end interface x3d_transpose_x_to_y + + interface x3d_transpose_y_to_z + module procedure x3d_transpose_y_to_z_real_short + module procedure x3d_transpose_y_to_z_real + module procedure x3d_transpose_y_to_z_cplx_short + module procedure x3d_transpose_y_to_z_cplx + end interface x3d_transpose_y_to_z + + interface x3d_transpose_z_to_y + module procedure x3d_transpose_z_to_y_real_short + module procedure x3d_transpose_z_to_y_real + module procedure x3d_transpose_z_to_y_cplx_short + module procedure x3d_transpose_z_to_y_cplx + end interface x3d_transpose_z_to_y + + interface x3d_transpose_y_to_x + module procedure x3d_transpose_y_to_x_real_short + module procedure x3d_transpose_y_to_x_real + module procedure x3d_transpose_y_to_x_cplx_short + module procedure x3d_transpose_y_to_x_cplx + end interface x3d_transpose_y_to_x contains + !############################################################################ + ! SUBROUTINE: x3d_transpose_x_to_y + ! DESCRIPTION: Wrapper around decomp2d_transpose to avoid MPI in case of + ! single core calculation + !############################################################################ + subroutine x3d_transpose_x_to_y_real(data_in, data_out, decomp) - !############################################################################ - !! SUBROUTINE: x3d_transpose_x_to_y - !! DESCRIPTION: Wrapper around decomp2d_transpose to avoid MPI in case of - !! single core calculation - !############################################################################ - subroutine x3d_transpose_x_to_y_real(data_in, data_out, decomp) - - use decomp_2d, only : transpose_x_to_y - - implicit none - - !! Input/Output - real(mytype), dimension(:,:,:), intent(in) :: data_in - real(mytype), dimension(:,:,:), intent(out) :: data_out - type(decomp_info), intent(in) :: decomp - - !! Local - integer :: i, j, k - - if (p_row == 1) then - do concurrent (k=1:decomp%xsz(3), j=1:decomp%xsz(2), i=1:decomp%xsz(1)) - data_out(i,j,k) = data_in(i,j,k) - enddo - else - call transpose_x_to_y(data_in,data_out,decomp) - endif - - end subroutine x3d_transpose_x_to_y_real - !############################################################################ - subroutine x3d_transpose_x_to_y_cplx(data_in, data_out, decomp) - - use decomp_2d, only : transpose_x_to_y - - implicit none - - !! Input/Output - complex(mytype), dimension(:,:,:), intent(in) :: data_in - complex(mytype), dimension(:,:,:), intent(out) :: data_out - type(decomp_info), intent(in) :: decomp - - !! Local - integer :: i, j, k - - if (p_row == 1) then - do concurrent (k=1:decomp%xsz(3), j=1:decomp%xsz(2), i=1:decomp%xsz(1)) - data_out(i,j,k) = data_in(i,j,k) - enddo - else - call transpose_x_to_y(data_in,data_out,decomp) - endif - - end subroutine x3d_transpose_x_to_y_cplx - - - !############################################################################ - !! SUBROUTINE: x3d_transpose_y_to_z - !! DESCRIPTION: Wrapper around decomp2d_transpose to avoid MPI in case of - !! single core calculation - !############################################################################ - subroutine x3d_transpose_y_to_z_real(data_in, data_out, decomp) + use decomp_2d, only: transpose_x_to_y - use decomp_2d, only : transpose_y_to_z + implicit none + + ! Input/Output + real(mytype), dimension(:, :, :), intent(in) :: data_in + real(mytype), dimension(:, :, :), intent(out) :: data_out + type(decomp_info), intent(in) :: decomp - implicit none + ! Local + integer :: i, j, k - !! Input/Output - real(mytype), dimension(:,:,:), intent(in) :: data_in - real(mytype), dimension(:,:,:), intent(out) :: data_out - type(decomp_info), intent(in) :: decomp + if (p_row == 1) then + do concurrent(k=1:decomp%xsz(3), j=1:decomp%xsz(2), i=1:decomp%xsz(1)) + data_out(i, j, k) = data_in(i, j, k) + end do + else + call transpose_x_to_y(data_in, data_out, decomp) + end if - !! Local - integer :: i, j, k + end subroutine x3d_transpose_x_to_y_real + !############################################################################ + subroutine x3d_transpose_x_to_y_cplx(data_in, data_out, decomp) + + use decomp_2d, only: transpose_x_to_y - if (p_col == 1) then - do concurrent (k=1:decomp%ysz(3), j=1:decomp%ysz(2), i=1:decomp%ysz(1)) - data_out(i,j,k) = data_in(i,j,k) - enddo - else - call transpose_y_to_z(data_in,data_out,decomp) - endif + implicit none + + ! Input/Output + complex(mytype), dimension(:, :, :), intent(in) :: data_in + complex(mytype), dimension(:, :, :), intent(out) :: data_out + type(decomp_info), intent(in) :: decomp - end subroutine x3d_transpose_y_to_z_real - !############################################################################ - subroutine x3d_transpose_y_to_z_cplx(data_in, data_out, decomp) + ! Local + integer :: i, j, k - use decomp_2d, only : transpose_y_to_z + if (p_row == 1) then + do concurrent(k=1:decomp%xsz(3), j=1:decomp%xsz(2), i=1:decomp%xsz(1)) + data_out(i, j, k) = data_in(i, j, k) + end do + else + call transpose_x_to_y(data_in, data_out, decomp) + end if - implicit none + end subroutine x3d_transpose_x_to_y_cplx - !! Input/Output - complex(mytype), dimension(:,:,:), intent(in) :: data_in - complex(mytype), dimension(:,:,:), intent(out) :: data_out - type(decomp_info), intent(in) :: decomp + !############################################################################ + ! SUBROUTINE: x3d_transpose_y_to_z + ! DESCRIPTION: Wrapper around decomp2d_transpose to avoid MPI in case of + ! single core calculation + !############################################################################ + subroutine x3d_transpose_y_to_z_real(data_in, data_out, decomp) - !! Local - integer :: i, j, k + use decomp_2d, only: transpose_y_to_z - if (p_col == 1) then - do concurrent (k=1:decomp%ysz(3), j=1:decomp%ysz(2), i=1:decomp%ysz(1)) - data_out(i,j,k) = data_in(i,j,k) - enddo - else - call transpose_y_to_z(data_in,data_out,decomp) - endif + implicit none + + ! Input/Output + real(mytype), dimension(:, :, :), intent(in) :: data_in + real(mytype), dimension(:, :, :), intent(out) :: data_out + type(decomp_info), intent(in) :: decomp - end subroutine x3d_transpose_y_to_z_cplx + ! Local + integer :: i, j, k + if (p_col == 1) then + do concurrent(k=1:decomp%ysz(3), j=1:decomp%ysz(2), i=1:decomp%ysz(1)) + data_out(i, j, k) = data_in(i, j, k) + end do + else + call transpose_y_to_z(data_in, data_out, decomp) + end if - !############################################################################ - !! SUBROUTINE: x3d_transpose_z_to_y - !! DESCRIPTION: Wrapper around decomp2d_transpose to avoid MPI in case of - !! single core calculation - !############################################################################ - subroutine x3d_transpose_z_to_y_real(data_in, data_out, decomp) + end subroutine x3d_transpose_y_to_z_real + !############################################################################ + subroutine x3d_transpose_y_to_z_cplx(data_in, data_out, decomp) + + use decomp_2d, only: transpose_y_to_z - use decomp_2d, only : transpose_z_to_y + implicit none + + ! Input/Output + complex(mytype), dimension(:, :, :), intent(in) :: data_in + complex(mytype), dimension(:, :, :), intent(out) :: data_out + type(decomp_info), intent(in) :: decomp - implicit none + ! Local + integer :: i, j, k - !! Input/Output - real(mytype), dimension(:,:,:), intent(in) :: data_in - real(mytype), dimension(:,:,:), intent(out) :: data_out - type(decomp_info), intent(in) :: decomp + if (p_col == 1) then + do concurrent(k=1:decomp%ysz(3), j=1:decomp%ysz(2), i=1:decomp%ysz(1)) + data_out(i, j, k) = data_in(i, j, k) + end do + else + call transpose_y_to_z(data_in, data_out, decomp) + end if - !! Local - integer :: i, j, k + end subroutine x3d_transpose_y_to_z_cplx - if (p_col == 1) then - do concurrent (k=1:decomp%zsz(3), j=1:decomp%zsz(2), i=1:decomp%zsz(1)) - data_out(i,j,k) = data_in(i,j,k) - enddo - else - call transpose_z_to_y(data_in,data_out,decomp) - endif + !############################################################################ + ! SUBROUTINE: x3d_transpose_z_to_y + ! DESCRIPTION: Wrapper around decomp2d_transpose to avoid MPI in case of + ! single core calculation + !############################################################################ + subroutine x3d_transpose_z_to_y_real(data_in, data_out, decomp) + + use decomp_2d, only: transpose_z_to_y + + implicit none + + ! Input/Output + real(mytype), dimension(:, :, :), intent(in) :: data_in + real(mytype), dimension(:, :, :), intent(out) :: data_out + type(decomp_info), intent(in) :: decomp - end subroutine x3d_transpose_z_to_y_real - !############################################################################ - subroutine x3d_transpose_z_to_y_cplx(data_in, data_out, decomp) + ! Local + integer :: i, j, k - use decomp_2d, only : transpose_z_to_y + if (p_col == 1) then + do concurrent(k=1:decomp%zsz(3), j=1:decomp%zsz(2), i=1:decomp%zsz(1)) + data_out(i, j, k) = data_in(i, j, k) + end do + else + call transpose_z_to_y(data_in, data_out, decomp) + end if - implicit none + end subroutine x3d_transpose_z_to_y_real + !############################################################################ + subroutine x3d_transpose_z_to_y_cplx(data_in, data_out, decomp) - !! Input/Output - complex(mytype), dimension(:,:,:), intent(in) :: data_in - complex(mytype), dimension(:,:,:), intent(out) :: data_out - type(decomp_info), intent(in) :: decomp + use decomp_2d, only: transpose_z_to_y - !! Local - integer :: i, j, k + implicit none - if (p_col == 1) then - do concurrent (k=1:decomp%zsz(3), j=1:decomp%zsz(2), i=1:decomp%zsz(1)) - data_out(i,j,k) = data_in(i,j,k) - enddo - else - call transpose_z_to_y(data_in,data_out,decomp) - endif + ! Input/Output + complex(mytype), dimension(:, :, :), intent(in) :: data_in + complex(mytype), dimension(:, :, :), intent(out) :: data_out + type(decomp_info), intent(in) :: decomp - end subroutine x3d_transpose_z_to_y_cplx + ! Local + integer :: i, j, k + if (p_col == 1) then + do concurrent(k=1:decomp%zsz(3), j=1:decomp%zsz(2), i=1:decomp%zsz(1)) + data_out(i, j, k) = data_in(i, j, k) + end do + else + call transpose_z_to_y(data_in, data_out, decomp) + end if - !############################################################################ - !! SUBROUTINE: x3d_transpose_y_to_z - !! DESCRIPTION: Wrapper around decomp2d_transpose to avoid MPI in case of - !! single core calculation - !############################################################################ - subroutine x3d_transpose_y_to_x_real(data_in, data_out, decomp) + end subroutine x3d_transpose_z_to_y_cplx - use decomp_2d, only : transpose_y_to_x + !############################################################################ + ! SUBROUTINE: x3d_transpose_y_to_z + ! DESCRIPTION: Wrapper around decomp2d_transpose to avoid MPI in case of + ! single core calculation + !############################################################################ + subroutine x3d_transpose_y_to_x_real(data_in, data_out, decomp) - implicit none + use decomp_2d, only: transpose_y_to_x - !! Input/Output - real(mytype), dimension(:,:,:), intent(in) :: data_in - real(mytype), dimension(:,:,:), intent(out) :: data_out - type(decomp_info), intent(in) :: decomp + implicit none - !! Local - integer :: i, j, k + ! Input/Output + real(mytype), dimension(:, :, :), intent(in) :: data_in + real(mytype), dimension(:, :, :), intent(out) :: data_out + type(decomp_info), intent(in) :: decomp - if (p_row == 1) then - do concurrent (k=1:decomp%ysz(3), j=1:decomp%ysz(2), i=1:decomp%ysz(1)) - data_out(i,j,k) = data_in(i,j,k) - enddo - else - call transpose_y_to_x(data_in,data_out,decomp) - endif + ! Local + integer :: i, j, k - end subroutine x3d_transpose_y_to_x_real - !############################################################################ - subroutine x3d_transpose_y_to_x_cplx(data_in, data_out, decomp) + if (p_row == 1) then + do concurrent(k=1:decomp%ysz(3), j=1:decomp%ysz(2), i=1:decomp%ysz(1)) + data_out(i, j, k) = data_in(i, j, k) + end do + else + call transpose_y_to_x(data_in, data_out, decomp) + end if - use decomp_2d, only : transpose_y_to_x + end subroutine x3d_transpose_y_to_x_real + !############################################################################ + subroutine x3d_transpose_y_to_x_cplx(data_in, data_out, decomp) - implicit none + use decomp_2d, only: transpose_y_to_x - !! Input/Output - complex(mytype), dimension(:,:,:), intent(in) :: data_in - complex(mytype), dimension(:,:,:), intent(out) :: data_out - type(decomp_info), intent(in) :: decomp + implicit none - !! Local - integer :: i, j, k + ! Input/Output + complex(mytype), dimension(:, :, :), intent(in) :: data_in + complex(mytype), dimension(:, :, :), intent(out) :: data_out + type(decomp_info), intent(in) :: decomp - if (p_row == 1) then - do concurrent (k=1:decomp%ysz(3), j=1:decomp%ysz(2), i=1:decomp%ysz(1)) - data_out(i,j,k) = data_in(i,j,k) - enddo - else - call transpose_y_to_x(data_in,data_out,decomp) - endif + ! Local + integer :: i, j, k - end subroutine x3d_transpose_y_to_x_cplx + if (p_row == 1) then + do concurrent(k=1:decomp%ysz(3), j=1:decomp%ysz(2), i=1:decomp%ysz(1)) + data_out(i, j, k) = data_in(i, j, k) + end do + else + call transpose_y_to_x(data_in, data_out, decomp) + end if + end subroutine x3d_transpose_y_to_x_cplx - !############################################################################ - !! SUBROUTINE: x3d_transpose_*_to_*_short - !! DESCRIPTION: Call the x3d_transpose_*_to_* with the decomp_info object - !############################################################################ - subroutine x3d_transpose_x_to_y_real_short(data_in, data_out) + !############################################################################ + ! SUBROUTINE: x3d_transpose_*_to_*_short + ! DESCRIPTION: Call the x3d_transpose_*_to_* with the decomp_info object + !############################################################################ + subroutine x3d_transpose_x_to_y_real_short(data_in, data_out) - use decomp_2d, only : xsize, ysize + use decomp_2d, only: xsize, ysize - implicit none + implicit none - !! Input/Output - real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: data_in - real(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(out) :: data_out + ! Input/Output + real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: data_in + real(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(out) :: data_out - call x3d_transpose_x_to_y(data_in, data_out, decomp_main) + call x3d_transpose_x_to_y(data_in, data_out, decomp_main) - end subroutine x3d_transpose_x_to_y_real_short - !############################################################################ - subroutine x3d_transpose_x_to_y_cplx_short(data_in, data_out) + end subroutine x3d_transpose_x_to_y_real_short + !############################################################################ + subroutine x3d_transpose_x_to_y_cplx_short(data_in, data_out) - use decomp_2d, only : xsize, ysize + use decomp_2d, only: xsize, ysize - implicit none + implicit none - !! Input/Output - complex(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: data_in - complex(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(out) :: data_out + ! Input/Output + complex(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(in) :: data_in + complex(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(out) :: data_out - call x3d_transpose_x_to_y(data_in, data_out, decomp_main) + call x3d_transpose_x_to_y(data_in, data_out, decomp_main) - end subroutine x3d_transpose_x_to_y_cplx_short - !############################################################################ - subroutine x3d_transpose_y_to_z_real_short(data_in, data_out) + end subroutine x3d_transpose_x_to_y_cplx_short + !############################################################################ + subroutine x3d_transpose_y_to_z_real_short(data_in, data_out) - use decomp_2d, only : ysize, zsize + use decomp_2d, only: ysize, zsize - implicit none + implicit none - !! Input/Output - real(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(in) :: data_in - real(mytype), dimension(zsize(1), zsize(2), zsize(3)), intent(out) :: data_out + ! Input/Output + real(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(in) :: data_in + real(mytype), dimension(zsize(1), zsize(2), zsize(3)), intent(out) :: data_out - call x3d_transpose_y_to_z(data_in, data_out, decomp_main) + call x3d_transpose_y_to_z(data_in, data_out, decomp_main) - end subroutine x3d_transpose_y_to_z_real_short - !############################################################################ - subroutine x3d_transpose_y_to_z_cplx_short(data_in, data_out) + end subroutine x3d_transpose_y_to_z_real_short + !############################################################################ + subroutine x3d_transpose_y_to_z_cplx_short(data_in, data_out) - use decomp_2d, only : ysize, zsize + use decomp_2d, only: ysize, zsize - implicit none + implicit none - !! Input/Output - complex(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(in) :: data_in - complex(mytype), dimension(zsize(1), zsize(2), zsize(3)), intent(out) :: data_out + ! Input/Output + complex(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(in) :: data_in + complex(mytype), dimension(zsize(1), zsize(2), zsize(3)), intent(out) :: data_out - call x3d_transpose_y_to_z(data_in, data_out, decomp_main) + call x3d_transpose_y_to_z(data_in, data_out, decomp_main) - end subroutine x3d_transpose_y_to_z_cplx_short - !############################################################################ - subroutine x3d_transpose_z_to_y_real_short(data_in, data_out) + end subroutine x3d_transpose_y_to_z_cplx_short + !############################################################################ + subroutine x3d_transpose_z_to_y_real_short(data_in, data_out) - use decomp_2d, only : zsize, ysize + use decomp_2d, only: zsize, ysize - implicit none + implicit none - !! Input/Output - real(mytype), dimension(zsize(1), zsize(2), zsize(3)), intent(in) :: data_in - real(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(out) :: data_out + ! Input/Output + real(mytype), dimension(zsize(1), zsize(2), zsize(3)), intent(in) :: data_in + real(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(out) :: data_out - call x3d_transpose_z_to_y(data_in, data_out, decomp_main) + call x3d_transpose_z_to_y(data_in, data_out, decomp_main) - end subroutine x3d_transpose_z_to_y_real_short - !############################################################################ - subroutine x3d_transpose_z_to_y_cplx_short(data_in, data_out) + end subroutine x3d_transpose_z_to_y_real_short + !############################################################################ + subroutine x3d_transpose_z_to_y_cplx_short(data_in, data_out) - use decomp_2d, only : zsize, ysize + use decomp_2d, only: zsize, ysize - implicit none + implicit none - !! Input/Output - complex(mytype), dimension(zsize(1), zsize(2), zsize(3)), intent(in) :: data_in - complex(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(out) :: data_out + ! Input/Output + complex(mytype), dimension(zsize(1), zsize(2), zsize(3)), intent(in) :: data_in + complex(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(out) :: data_out - call x3d_transpose_z_to_y(data_in, data_out, decomp_main) + call x3d_transpose_z_to_y(data_in, data_out, decomp_main) - end subroutine x3d_transpose_z_to_y_cplx_short - !############################################################################ - subroutine x3d_transpose_y_to_x_real_short(data_in, data_out) + end subroutine x3d_transpose_z_to_y_cplx_short + !############################################################################ + subroutine x3d_transpose_y_to_x_real_short(data_in, data_out) - use decomp_2d, only : ysize, xsize + use decomp_2d, only: ysize, xsize - implicit none + implicit none - !! Input/Output - real(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(in) :: data_in - real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(out) :: data_out + ! Input/Output + real(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(in) :: data_in + real(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(out) :: data_out - call x3d_transpose_y_to_x(data_in, data_out, decomp_main) + call x3d_transpose_y_to_x(data_in, data_out, decomp_main) - end subroutine x3d_transpose_y_to_x_real_short - !############################################################################ - subroutine x3d_transpose_y_to_x_cplx_short(data_in, data_out) + end subroutine x3d_transpose_y_to_x_real_short + !############################################################################ + subroutine x3d_transpose_y_to_x_cplx_short(data_in, data_out) - use decomp_2d, only : ysize, xsize + use decomp_2d, only: ysize, xsize - implicit none + implicit none - !! Input/Output - complex(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(in) :: data_in - complex(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(out) :: data_out + ! Input/Output + complex(mytype), dimension(ysize(1), ysize(2), ysize(3)), intent(in) :: data_in + complex(mytype), dimension(xsize(1), xsize(2), xsize(3)), intent(out) :: data_out - call x3d_transpose_y_to_x(data_in, data_out, decomp_main) + call x3d_transpose_y_to_x(data_in, data_out, decomp_main) - end subroutine x3d_transpose_y_to_x_cplx_short + end subroutine x3d_transpose_y_to_x_cplx_short end module x3d_transpose diff --git a/src/xcompact3d.f90 b/src/xcompact3d.f90 index 031fa64..effa58d 100644 --- a/src/xcompact3d.f90 +++ b/src/xcompact3d.f90 @@ -4,78 +4,78 @@ program xcompact3d - use MPI + use MPI - use var - use decomp_2d, only : nrank, xsize, real_type, decomp_2d_warning - use param, only : dt, zero, itr - use transeq, only : calculate_transeq_rhs - use navier, only : solve_poisson, cor_vel - use case - use time_integrators, only : int_time + use var + use decomp_2d, only: nrank, xsize, real_type, decomp_2d_warning + use param, only: dt, zero, itr + use transeq, only: calculate_transeq_rhs + use navier, only: solve_poisson, cor_vel + use case + use time_integrators, only: int_time - implicit none + implicit none - double precision :: tstart, tend, telapsed, tmin, tmax - !real :: trun - integer :: i, j, k - integer :: ndt, ndt_max - integer :: code + double precision :: tstart, tend, telapsed, tmin, tmax + !real :: trun + integer :: i, j, k + integer :: ndt, ndt_max + integer :: code - call boot_xcompact3d() + call boot_xcompact3d() - call init_xcompact3d(ndt_max) + call init_xcompact3d(ndt_max) - call case_init(ux1, uy1, uz1) + call case_init(ux1, uy1, uz1) - telapsed = 0 - tmin = telapsed - ndt = 1 + telapsed = 0 + tmin = telapsed + ndt = 1 - do while(ndt < ndt_max) + do while (ndt < ndt_max) - itr = 1 ! no inner iterations - !call init_flowfield() + itr = 1 ! no inner iterations + !call init_flowfield() - tstart = MPI_Wtime() + tstart = MPI_Wtime() - call case_bc(ux1, uy1, uz1) + call case_bc(ux1, uy1, uz1) - call calculate_transeq_rhs(dux1,duy1,duz1,ux1,uy1,uz1) - call int_time(ux1,uy1,uz1,dux1,duy1,duz1) + call calculate_transeq_rhs(dux1, duy1, duz1, ux1, uy1, uz1) + call int_time(ux1, uy1, uz1, dux1, duy1, duz1) - !do concurrent (k=1:zsize(3), j=1:zsize(2), i=1:zsize(1)) - ! divu3(:,:,:) = zero - !enddo - call solve_poisson(pp3,px1,py1,pz1,ux1,uy1,uz1) - call cor_vel(ux1,uy1,uz1,px1,py1,pz1) + !do concurrent (k=1:zsize(3), j=1:zsize(2), i=1:zsize(1)) + ! divu3(:,:,:) = zero + !enddo + call solve_poisson(pp3, px1, py1, pz1, ux1, uy1, uz1) + call cor_vel(ux1, uy1, uz1, px1, py1, pz1) - tend = MPI_Wtime() - telapsed = telapsed + (tend - tstart) - tmin = telapsed - tmax = telapsed + tend = MPI_Wtime() + telapsed = telapsed + (tend - tstart) + tmin = telapsed + tmax = telapsed - call MPI_Allreduce(telapsed, tmin, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, code) - if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_Allreduce") - call MPI_Allreduce(telapsed, tmax, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, code) - if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_Allreduce") - if (nrank == 0) then - print *, "Elapse time min ", tmin, " max ", tmax - end if + call MPI_Allreduce(telapsed, tmin, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_Allreduce") + call MPI_Allreduce(telapsed, tmax, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, code) + if (code /= 0) call decomp_2d_warning(__FILE__, __LINE__, code, "MPI_Allreduce") + if (nrank == 0) then + print *, "Elapse time min ", tmin, " max ", tmax + end if - ndt = ndt + 1 - call case_postprocess(ux1, uy1, uz1, ndt) + ndt = ndt + 1 + call case_postprocess(ux1, uy1, uz1, ndt) - end do + end do - if (nrank == 0) then - print *, "Elapsed time (min-max) [s]: ", tmin, tmax - print *, "Timesteps completed: ", ndt - print *, "Compute rate (min-max)[dt/s]: ", ndt / tmin, ndt / tmax - end if + if (nrank == 0) then + print *, "Elapsed time (min-max) [s]: ", tmin, tmax + print *, "Timesteps completed: ", ndt + print *, "Compute rate (min-max)[dt/s]: ", ndt/tmin, ndt/tmax + end if - call case_finalize() - call finalise_xcompact3d(.true.) + call case_finalize() + call finalise_xcompact3d(.true.) end program xcompact3d !########################################################################