Forked from
NEMO Workspace / Nemo
947 commits behind, 63 commits ahead of the upstream repository.
-
Sebastien MASSON authored02d75a13
Code owners
Assign users and groups as approvers for specific file changes. Learn more.
lbc_nfd_generic.h90 22.78 KiB
SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfld )
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
!
INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices
INTEGER :: ipi, ipj, ipk, ipl, ihls ! dimension of the input array
INTEGER :: ii1, ii2, ij1, ij2
!!----------------------------------------------------------------------
!
DO jf = 1, kfld ! Loop on the number of arrays to be treated
!
ipi = SIZE(ptab(jf)%pt4d,1)
ipj = SIZE(ptab(jf)%pt4d,2)
ipk = SIZE(ptab(jf)%pt4d,3)
ipl = SIZE(ptab(jf)%pt4d,4)
!
ihls = ( ipi - Ni0glo ) / 2
!
IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
!
SELECT CASE ( cd_nat(jf) )
CASE ( 'T' , 'W' ) ! T-, W-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ihls+1
ii1 = ihls + ji
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from ihls+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = 2 + ihls + ji - 1 ! ends at: 2 + ihls + ipi - 2*ihls - 1 - 1 = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, COUNT( (/ihls > 0/) ) ! point ipi - ihls + 1
ii1 = ipi - ihls + ji
ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls-1 ! last ihls-1 points
ii1 = ipi - ihls + 1 + ji ! ends at: ipi - ihls + 1 + ihls - 1 = ipi
ii2 = ipi - ihls + 1 - ji ! ends at: ipi - ihls + 1 - ihls + 1 = ipi - 2*ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - ihls - 1) + 1 = ipi - ihls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls - 1) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done) ! ! as we just changed points ipi-2ihls+1 to ipi-ihls
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last ihls-1 points: have been or will be done by e-w periodicity
END DO
!
END DO ; END DO
CASE ( 'U' ) ! U-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-ihls
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last ihls-1 points: have been or will be done by e-w periodicity
END DO
!
END DO ; END DO
CASE ( 'V' ) ! V-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last ihls+1 lines (from ipj to ipj-ihls) : full
DO jj = 1, ihls+1
ij1 = ipj - jj + 1 ! ends at: ipj - ( ihls + 1 ) + 1 = ipj - ihls
ij2 = ipj - 2*ihls + jj - 2 ! ends at: ipj - 2*ihls + ihls + 1 - 2 = ipj - ihls - 1
!
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ihls+1
ii1 = ihls + ji
ii2 = ii1 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from ihls+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = 2 + ihls + ji - 1 ! ends at: 2 + ihls + ipi - 2*ihls - 1 - 1 = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
IF( ihls > 0 ) THEN
DO ji = 1, COUNT( (/ihls > 0/) ) ! point ipi - ihls + 1
ii1 = ipi - ihls + ji
ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
ENDIF
DO ji = 1, ihls-1 ! last ihls-1 points
ii1 = ipi - ihls + 1 + ji ! ends at: ipi - ihls + 1 + ihls - 1 = ipi
ii2 = ipi - ihls + 1 - ji ! ends at: ipi - ihls + 1 - ihls + 1 = ipi - 2*ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
END DO ; END DO
CASE ( 'F' ) ! F-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last ihls+1 lines (from ipj to ipj-ihls) : full
DO jj = 1, ihls+1
ij1 = ipj - jj + 1 ! ends at: ipj - ( ihls + 1 ) + 1 = ipj - ihls
ij2 = ipj - 2*ihls + jj - 2 ! ends at: ipj - 2*ihls + ihls + 1 - 2 = ipj - ihls - 1
!
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
END DO; END DO
END SELECT ! cd_nat(jf)
!
ENDIF ! c_NFtype == 'T'
!
IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot
!
SELECT CASE ( cd_nat(jf) )
CASE ( 'T' , 'W' ) ! T-, W-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj + 1 - jj ! ends at: ipj + 1 - ihls
ij2 = ipj - 2*ihls + jj ! ends at: ipj - 2*ihls + ihls = ipj - ihls
!
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
END DO; END DO
CASE ( 'U' ) ! U-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj + 1 - jj ! ends at: ipj + 1 - ihls
ij2 = ipj - 2*ihls + jj ! ends at: ipj - 2*ihls + ihls = ipj - ihls
!
DO ji = 1, ihls-1 ! first ihls-1 points
ii1 = ji ! ends at: ihls-1
ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ihls (here ihls > 0 so it is ok)
ii1 = ihls + ji - 1
ii2 = ipi - ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from ihls+1 to ipi - ihls - 1 (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ( ipi - 2*ihls - 1 ) = ipi - ihls - 1
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ipi - ihls
ii1 = ipi - ihls + ji - 1
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ihls = ipi - 2*ihls
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
END DO; END DO
CASE ( 'V' ) ! V-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO END DO
!
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-ihls
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last ihls points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
CASE ( 'F' ) ! F-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, ihls-1 ! first ihls-1 points
ii1 = ji ! ends at: ihls-1
ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ihls (here ihls > 0 so it is ok)
ii1 = ihls + ji - 1
ii2 = ipi - ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from ihls+1 to ipi - ihls - 1 (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ( ipi - 2*ihls - 1 ) = ipi - ihls - 1
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ipi - ihls
ii1 = ipi - ihls + ji - 1
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ihls = ipi - 2*ihls
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - ihls-1 (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, ihls-1 ! first ihls-1 points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-nn_hl-1
ii1 = ji ! ends at: ihls ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last ihls points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
END SELECT ! cd_nat(jf)
!
ENDIF ! c_NFtype == 'F'
!
END DO ! kfld
!
END SUBROUTINE lbc_nfd_/**/PRECISION