- Timestamp:
- 2021-03-03T16:04:57+01:00 (3 years ago)
- Location:
- NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC
- Files:
-
- 4 deleted
- 10 edited
- 3 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lbc_nfd_ext_generic.h90
r13286 r14574 1 ! !== IN: ptab is an array ==!2 #define NAT_IN(k) cd_nat3 #define SGN_IN(k) psgn4 #define F_SIZE(ptab) 15 #if defined DIM_2d6 # define ARRAY_IN(i,j,k,l,f) ptab(i,j)7 # define K_SIZE(ptab) 18 # define L_SIZE(ptab) 19 #endif10 #if defined SINGLE_PRECISION11 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)12 # define PRECISION sp13 #else14 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)15 # define PRECISION dp16 #endif17 1 18 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj )2 SUBROUTINE lbc_nfd_ext_/**/PRECISION( ptab, cd_nat, psgn, kextj ) 19 3 !!---------------------------------------------------------------------- 20 INTEGER , INTENT(in ) :: kextj ! extra halo width at north fold, declared before its use in ARRAY_TYPE21 ARRAY_TYPE(:,1-kextj:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied22 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points23 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary4 REAL(PRECISION), DIMENSION(:,1-kextj:),INTENT(inout) :: ptab 5 CHARACTER(len=1), INTENT(in ) :: cd_nat ! nature of array grid-points 6 REAL(PRECISION), INTENT(in ) :: psgn ! sign used across the north fold boundary 7 INTEGER, INTENT(in ) :: kextj ! extra halo width at north fold 24 8 ! 25 INTEGER :: ji, jj, j k, jl, jh, jf! dummy loop indices26 INTEGER :: ip i, ipj, ipk, ipl, ipf ! dimension of the input array9 INTEGER :: ji, jj, jh ! dummy loop indices 10 INTEGER :: ipj 27 11 INTEGER :: ijt, iju, ipjm1 28 12 !!---------------------------------------------------------------------- 29 !30 ipk = K_SIZE(ptab) ! 3rd dimension31 ipl = L_SIZE(ptab) ! 4th -32 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)33 !34 13 ! 35 14 SELECT CASE ( jpni ) … … 39 18 ! 40 19 ipjm1 = ipj-1 20 ! 21 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 22 ! 23 SELECT CASE ( cd_nat ) 24 CASE ( 'T' , 'W' ) ! T-, W-point 25 DO jh = 0, kextj 26 DO ji = 2, jpiglo 27 ijt = jpiglo-ji+2 28 ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) 29 END DO 30 ptab(1,ipj+jh) = psgn * ptab(3,ipj-2-jh) 31 END DO 32 DO ji = jpiglo/2+1, jpiglo 33 ijt = jpiglo-ji+2 34 ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) 35 END DO 36 CASE ( 'U' ) ! U-point 37 DO jh = 0, kextj 38 DO ji = 2, jpiglo-1 39 iju = jpiglo-ji+1 40 ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-2-jh) 41 END DO 42 ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-2-jh) 43 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-2-jh) 44 END DO 45 DO ji = jpiglo/2, jpiglo-1 46 iju = jpiglo-ji+1 47 ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) 48 END DO 49 CASE ( 'V' ) ! V-point 50 DO jh = 0, kextj 51 DO ji = 2, jpiglo 52 ijt = jpiglo-ji+2 53 ptab(ji,ipj-1+jh) = psgn * ptab(ijt,ipj-2-jh) 54 ptab(ji,ipj+jh ) = psgn * ptab(ijt,ipj-3-jh) 55 END DO 56 ptab(1,ipj+jh) = psgn * ptab(3,ipj-3-jh) 57 END DO 58 CASE ( 'F' ) ! F-point 59 DO jh = 0, kextj 60 DO ji = 1, jpiglo-1 61 iju = jpiglo-ji+1 62 ptab(ji,ipj-1+jh) = psgn * ptab(iju,ipj-2-jh) 63 ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-3-jh) 64 END DO 65 END DO 66 DO jh = 0, kextj 67 ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-3-jh) 68 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-3-jh) 69 END DO 70 END SELECT 71 ! 72 ENDIF ! c_NFtype == 'T' 73 ! 74 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 75 ! 76 SELECT CASE ( cd_nat ) 77 CASE ( 'T' , 'W' ) ! T-, W-point 78 DO jh = 0, kextj 79 DO ji = 1, jpiglo 80 ijt = jpiglo-ji+1 81 ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-1-jh) 82 END DO 83 END DO 84 CASE ( 'U' ) ! U-point 85 DO jh = 0, kextj 86 DO ji = 1, jpiglo-1 87 iju = jpiglo-ji 88 ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-1-jh) 89 END DO 90 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-1-jh) 91 END DO 92 CASE ( 'V' ) ! V-point 93 DO jh = 0, kextj 94 DO ji = 1, jpiglo 95 ijt = jpiglo-ji+1 96 ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) 97 END DO 98 END DO 99 DO ji = jpiglo/2+1, jpiglo 100 ijt = jpiglo-ji+1 101 ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) 102 END DO 103 CASE ( 'F' ) ! F-point 104 DO jh = 0, kextj 105 DO ji = 1, jpiglo-1 106 iju = jpiglo-ji 107 ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-2-jh) 108 END DO 109 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-2-jh) 110 END DO 111 DO ji = jpiglo/2+1, jpiglo-1 112 iju = jpiglo-ji 113 ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) 114 END DO 115 END SELECT 116 ! 117 ENDIF ! c_NFtype == 'F' 118 ! 119 END SUBROUTINE lbc_nfd_ext_/**/PRECISION 41 120 42 !43 DO jf = 1, ipf ! Loop on the number of arrays to be treated44 !45 SELECT CASE ( npolj )46 !47 CASE ( 3 , 4 ) ! * North fold T-point pivot48 !49 SELECT CASE ( NAT_IN(jf) )50 CASE ( 'T' , 'W' ) ! T-, W-point51 DO jh = 0, kextj52 DO ji = 2, jpiglo53 ijt = jpiglo-ji+254 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)55 END DO56 ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-2-jh,:,:,jf)57 END DO58 DO ji = jpiglo/2+1, jpiglo59 ijt = jpiglo-ji+260 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf)61 END DO62 CASE ( 'U' ) ! U-point63 DO jh = 0, kextj64 DO ji = 2, jpiglo-165 iju = jpiglo-ji+166 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf)67 END DO68 ARRAY_IN( 1 ,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-2-jh,:,:,jf)69 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-2-jh,:,:,jf)70 END DO71 DO ji = jpiglo/2, jpiglo-172 iju = jpiglo-ji+173 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf)74 END DO75 CASE ( 'V' ) ! V-point76 DO jh = 0, kextj77 DO ji = 2, jpiglo78 ijt = jpiglo-ji+279 ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)80 ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-3-jh,:,:,jf)81 END DO82 ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-3-jh,:,:,jf)83 END DO84 CASE ( 'F' ) ! F-point85 DO jh = 0, kextj86 DO ji = 1, jpiglo-187 iju = jpiglo-ji+188 ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf)89 ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-3-jh,:,:,jf)90 END DO91 END DO92 DO jh = 0, kextj93 ARRAY_IN( 1 ,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-3-jh,:,:,jf)94 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-3-jh,:,:,jf)95 END DO96 END SELECT97 !98 CASE ( 5 , 6 ) ! * North fold F-point pivot99 !100 SELECT CASE ( NAT_IN(jf) )101 CASE ( 'T' , 'W' ) ! T-, W-point102 DO jh = 0, kextj103 DO ji = 1, jpiglo104 ijt = jpiglo-ji+1105 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-1-jh,:,:,jf)106 END DO107 END DO108 CASE ( 'U' ) ! U-point109 DO jh = 0, kextj110 DO ji = 1, jpiglo-1111 iju = jpiglo-ji112 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-1-jh,:,:,jf)113 END DO114 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-1-jh,:,:,jf)115 END DO116 CASE ( 'V' ) ! V-point117 DO jh = 0, kextj118 DO ji = 1, jpiglo119 ijt = jpiglo-ji+1120 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)121 END DO122 END DO123 DO ji = jpiglo/2+1, jpiglo124 ijt = jpiglo-ji+1125 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf)126 END DO127 CASE ( 'F' ) ! F-point128 DO jh = 0, kextj129 DO ji = 1, jpiglo-1130 iju = jpiglo-ji131 ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf)132 END DO133 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-2-jh,:,:,jf)134 END DO135 DO ji = jpiglo/2+1, jpiglo-1136 iju = jpiglo-ji137 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf)138 END DO139 END SELECT140 !141 CASE DEFAULT ! * closed : the code probably never go through142 !143 SELECT CASE ( NAT_IN(jf) )144 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points145 ARRAY_IN(:, 1:1-kextj ,:,:,jf) = 0._wp146 ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp147 CASE ( 'F' ) ! F-point148 ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp149 END SELECT150 !151 END SELECT ! npolj152 !153 END DO154 !155 END SUBROUTINE ROUTINE_NFD156 157 #undef PRECISION158 #undef ARRAY_TYPE159 #undef ARRAY_IN160 #undef NAT_IN161 #undef SGN_IN162 #undef K_SIZE163 #undef L_SIZE164 #undef F_SIZE -
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lbc_nfd_generic.h90
r13286 r14574 1 #if defined MULTI2 # define NAT_IN(k) cd_nat(k)3 # define SGN_IN(k) psgn(k)4 # define F_SIZE(ptab) kfld5 # if defined DIM_2d6 # if defined SINGLE_PRECISION7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f)8 # else9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f)10 # endif11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)12 # define J_SIZE(ptab) SIZE(ptab(1)%pt2d,2)13 # define K_SIZE(ptab) 114 # define L_SIZE(ptab) 115 # endif16 # if defined DIM_3d17 # if defined SINGLE_PRECISION18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f)19 # else20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f)21 # endif22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)23 # define J_SIZE(ptab) SIZE(ptab(1)%pt3d,2)24 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)25 # define L_SIZE(ptab) 126 # endif27 # if defined DIM_4d28 # if defined SINGLE_PRECISION29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f)30 # else31 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f)32 # endif33 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)34 # define J_SIZE(ptab) SIZE(ptab(1)%pt4d,2)35 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)36 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)37 # endif38 #else39 ! !== IN: ptab is an array ==!40 # define NAT_IN(k) cd_nat41 # define SGN_IN(k) psgn42 # define F_SIZE(ptab) 143 # if defined DIM_2d44 # define ARRAY_IN(i,j,k,l,f) ptab(i,j)45 # define J_SIZE(ptab) SIZE(ptab,2)46 # define K_SIZE(ptab) 147 # define L_SIZE(ptab) 148 # endif49 # if defined DIM_3d50 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k)51 # define J_SIZE(ptab) SIZE(ptab,2)52 # define K_SIZE(ptab) SIZE(ptab,3)53 # define L_SIZE(ptab) 154 # endif55 # if defined DIM_4d56 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l)57 # define J_SIZE(ptab) SIZE(ptab,2)58 # define K_SIZE(ptab) SIZE(ptab,3)59 # define L_SIZE(ptab) SIZE(ptab,4)60 # endif61 # if defined SINGLE_PRECISION62 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)63 # else64 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)65 # endif66 #endif67 1 68 # if defined SINGLE_PRECISION 69 # define PRECISION sp 70 # else 71 # define PRECISION dp 72 # endif 73 74 #if defined MULTI 75 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 76 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 77 #else 78 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn ) 79 #endif 80 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 2 SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, khls, kfld ) 3 TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 4 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 5 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary 6 INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls 7 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 83 8 ! 84 9 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 85 INTEGER :: 10 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 86 11 INTEGER :: ii1, ii2, ij1, ij2 87 12 !!---------------------------------------------------------------------- 88 13 ! 89 ipj = J_SIZE(ptab) ! 2nd dimension 90 ipk = K_SIZE(ptab) ! 3rd - 91 ipl = L_SIZE(ptab) ! 4th - 92 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 14 ipi = SIZE(ptab(1)%pt4d,1) 15 ipj = SIZE(ptab(1)%pt4d,2) 16 ipk = SIZE(ptab(1)%pt4d,3) 17 ipl = SIZE(ptab(1)%pt4d,4) 18 ipf = kfld 19 ! 20 IF( ipi /= Ni0glo+2*khls ) THEN 21 WRITE(ctmp1,*) 'lbc_nfd input array does not match khls', ipi, khls, Ni0glo 22 CALL ctl_stop( 'STOP', ctmp1 ) 23 ENDIF 93 24 ! 94 25 DO jf = 1, ipf ! Loop on the number of arrays to be treated 95 26 ! 96 SELECT CASE ( npolj ) 27 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 28 ! 29 SELECT CASE ( cd_nat(jf) ) 30 CASE ( 'T' , 'W' ) ! T-, W-point 31 DO jl = 1, ipl; DO jk = 1, ipk 32 ! 33 ! last khls lines (from ipj to ipj-khls+1) : full 34 DO jj = 1, khls 35 ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 36 ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 37 ! 38 DO ji = 1, khls ! first khls points 39 ii1 = ji ! ends at: khls 40 ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 41 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 42 END DO 43 DO ji = 1, 1 ! point khls+1 44 ii1 = khls + ji 45 ii2 = ii1 46 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 47 END DO 48 DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) 49 ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls 50 ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 51 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 52 END DO 53 DO ji = 1, 1 ! point ipi - khls + 1 54 ii1 = ipi - khls + ji 55 ii2 = khls + ji 56 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 57 END DO 58 DO ji = 1, khls-1 ! last khls-1 points 59 ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi 60 ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 61 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 62 END DO 63 END DO 64 ! 65 ! line number ipj-khls : right half 66 DO jj = 1, 1 67 ij1 = ipj - khls 68 ij2 = ij1 ! same line 69 ! 70 DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) 71 ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - khls - 1) + 1 = ipi - khls 72 ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls - 1) + 1 = khls + 2 73 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 74 END DO 75 DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) 76 ! ! as we just changed points ipi-2khls+1 to ipi-khls 77 ii1 = ji ! ends at: khls 78 ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 79 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 80 END DO 81 ! ! last khls-1 points: have been / will done by e-w periodicity 82 END DO 83 ! 84 END DO; END DO 85 CASE ( 'U' ) ! U-point 86 DO jl = 1, ipl; DO jk = 1, ipk 87 ! 88 ! last khls lines (from ipj to ipj-khls+1) : full 89 DO jj = 1, khls 90 ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 91 ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 92 ! 93 DO ji = 1, khls ! first khls points 94 ii1 = ji ! ends at: khls 95 ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 96 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 97 END DO 98 DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) 99 ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls 100 ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 101 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 102 END DO 103 DO ji = 1, khls ! last khls points 104 ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi 105 ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 106 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 107 END DO 108 END DO 109 ! 110 ! line number ipj-khls : right half 111 DO jj = 1, 1 112 ij1 = ipj - khls 113 ij2 = ij1 ! same line 114 ! 115 DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) 116 ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls 117 ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 118 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 119 END DO 120 DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) 121 ! ! as we just changed points ipi-2khls+1 to ipi-khls 122 ii1 = ji ! ends at: khls 123 ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 124 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 125 END DO 126 ! ! last khls-1 points: have been / will done by e-w periodicity 127 END DO 128 ! 129 END DO; END DO 130 CASE ( 'V' ) ! V-point 131 DO jl = 1, ipl; DO jk = 1, ipk 132 ! 133 ! last khls+1 lines (from ipj to ipj-khls) : full 134 DO jj = 1, khls+1 135 ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls 136 ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 137 ! 138 DO ji = 1, khls ! first khls points 139 ii1 = ji ! ends at: khls 140 ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 141 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 142 END DO 143 DO ji = 1, 1 ! point khls+1 144 ii1 = khls + ji 145 ii2 = ii1 146 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 147 END DO 148 DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) 149 ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls 150 ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 151 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 152 END DO 153 DO ji = 1, 1 ! point ipi - khls + 1 154 ii1 = ipi - khls + ji 155 ii2 = khls + ji 156 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 157 END DO 158 DO ji = 1, khls-1 ! last khls-1 points 159 ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi 160 ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 161 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 162 END DO 163 END DO 164 ! 165 END DO; END DO 166 CASE ( 'F' ) ! F-point 167 DO jl = 1, ipl; DO jk = 1, ipk 168 ! 169 ! last khls+1 lines (from ipj to ipj-khls) : full 170 DO jj = 1, khls+1 171 ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls 172 ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 173 ! 174 DO ji = 1, khls ! first khls points 175 ii1 = ji ! ends at: khls 176 ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 177 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 178 END DO 179 DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) 180 ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls 181 ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 182 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 183 END DO 184 DO ji = 1, khls ! last khls points 185 ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi 186 ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 187 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 188 END DO 189 END DO 190 ! 191 END DO; END DO 192 END SELECT ! cd_nat(jf) 193 ! 194 ENDIF ! c_NFtype == 'T' 97 195 ! 98 CASE ( 3 , 4 ) ! * North fold T-point pivot196 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 99 197 ! 100 SELECT CASE ( NAT_IN(jf))198 SELECT CASE ( cd_nat(jf) ) 101 199 CASE ( 'T' , 'W' ) ! T-, W-point 102 200 DO jl = 1, ipl; DO jk = 1, ipk 103 201 ! 104 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 105 DO jj = 1, nn_hls 106 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 107 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 108 ! 109 DO ji = 1, nn_hls ! first nn_hls points 110 ii1 = ji ! ends at: nn_hls 111 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 112 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 113 END DO 114 DO ji = 1, 1 ! point nn_hls+1 115 ii1 = nn_hls + ji 202 ! first: line number ipj-khls : 3 points 203 DO jj = 1, 1 204 ij1 = ipj - khls 205 ij2 = ij1 ! same line 206 ! 207 DO ji = 1, 1 ! points from ipi/2+1 208 ii1 = ipi/2 + ji 209 ii2 = ipi/2 - ji + 1 210 ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... 211 END DO 212 DO ji = 1, 1 ! points ipi - khls 213 ii1 = ipi - khls + ji - 1 214 ii2 = khls + ji 215 ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... 216 END DO 217 DO ji = 1, 1 ! point khls: redo it just in case (if e-w periodocity already done) 218 ! ! as we just changed point ipi - khls 219 ii1 = khls + ji - 1 220 ii2 = khls + ji 221 ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... 222 END DO 223 END DO 224 ! 225 ! Second: last khls lines (from ipj to ipj-khls+1) : full 226 DO jj = 1, khls 227 ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls 228 ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls 229 ! 230 DO ji = 1, khls ! first khls points 231 ii1 = ji ! ends at: khls 232 ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 233 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 234 END DO 235 DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) 236 ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls 237 ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 238 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 239 END DO 240 DO ji = 1, khls ! last khls points 241 ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi 242 ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 243 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 244 END DO 245 END DO 246 ! 247 END DO; END DO 248 CASE ( 'U' ) ! U-point 249 DO jl = 1, ipl; DO jk = 1, ipk 250 ! 251 ! last khls lines (from ipj to ipj-khls+1) : full 252 DO jj = 1, khls 253 ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls 254 ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls 255 ! 256 DO ji = 1, khls-1 ! first khls-1 points 257 ii1 = ji ! ends at: khls-1 258 ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 259 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 260 END DO 261 DO ji = 1, 1 ! point khls 262 ii1 = khls + ji - 1 263 ii2 = ipi - ii1 264 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 265 END DO 266 DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) 267 ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 268 ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 269 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 270 END DO 271 DO ji = 1, 1 ! point ipi - khls 272 ii1 = ipi - khls + ji - 1 116 273 ii2 = ii1 117 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 118 END DO 119 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 120 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 121 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 122 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 123 END DO 124 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 125 ii1 = jpiglo - nn_hls + ji 126 ii2 = nn_hls + ji 127 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 128 END DO 129 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 130 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 131 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 132 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 133 END DO 134 END DO 135 ! 136 ! line number ipj-nn_hls : right half 137 DO jj = 1, 1 138 ij1 = ipj - nn_hls 139 ij2 = ij1 ! same line 140 ! 141 DO ji = 1, Ni0glo/2-1 ! points from jpiglo/2+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 142 ii1 = jpiglo/2 + ji + 1 ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls - 1) + 1 = jpiglo - nn_hls 143 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1) + 1 = nn_hls + 2 144 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 145 END DO 146 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 147 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 148 ii1 = ji ! ends at: nn_hls 149 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 150 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 151 END DO 152 ! ! last nn_hls-1 points: have been / will done by e-w periodicity 153 END DO 154 ! 155 END DO; END DO 156 CASE ( 'U' ) ! U-point 157 DO jl = 1, ipl; DO jk = 1, ipk 158 ! 159 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 160 DO jj = 1, nn_hls 161 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 162 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 163 ! 164 DO ji = 1, nn_hls ! first nn_hls points 165 ii1 = ji ! ends at: nn_hls 166 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 167 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 168 END DO 169 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 170 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 171 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 172 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 173 END DO 174 DO ji = 1, nn_hls ! last nn_hls points 175 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 176 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 177 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 178 END DO 179 END DO 180 ! 181 ! line number ipj-nn_hls : right half 182 DO jj = 1, 1 183 ij1 = ipj - nn_hls 184 ij2 = ij1 ! same line 185 ! 186 DO ji = 1, Ni0glo/2 ! points from jpiglo/2+1 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 187 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 188 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 189 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 190 END DO 191 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 192 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 193 ii1 = ji ! ends at: nn_hls 194 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 195 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 196 END DO 197 ! ! last nn_hls-1 points: have been / will done by e-w periodicity 274 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 275 END DO 276 DO ji = 1, khls ! last khls points 277 ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi 278 ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls 279 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 280 END DO 198 281 END DO 199 282 ! … … 202 285 DO jl = 1, ipl; DO jk = 1, ipk 203 286 ! 204 ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full 205 DO jj = 1, nn_hls+1 206 ij1 = ipj - jj + 1 ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls 207 ij2 = ipj - 2*nn_hls + jj - 2 ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1 208 ! 209 DO ji = 1, nn_hls ! first nn_hls points 210 ii1 = ji ! ends at: nn_hls 211 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 212 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 213 END DO 214 DO ji = 1, 1 ! point nn_hls+1 215 ii1 = nn_hls + ji 287 ! last khls lines (from ipj to ipj-khls+1) : full 288 DO jj = 1, khls 289 ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 290 ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 291 ! 292 DO ji = 1, khls ! first khls points 293 ii1 = ji ! ends at: khls 294 ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 295 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 296 END DO 297 DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) 298 ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls 299 ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 300 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 301 END DO 302 DO ji = 1, khls ! last khls points 303 ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi 304 ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 305 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 306 END DO 307 END DO 308 ! 309 ! line number ipj-khls : right half 310 DO jj = 1, 1 311 ij1 = ipj - khls 312 ij2 = ij1 ! same line 313 ! 314 DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) 315 ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls 316 ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 317 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 318 END DO 319 DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) 320 ! ! as we just changed points ipi-2khls+1 to ipi-khls 321 ii1 = ji ! ends at: khls 322 ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 323 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 324 END DO 325 ! ! last khls points: have been / will done by e-w periodicity 326 END DO 327 ! 328 END DO; END DO 329 CASE ( 'F' ) ! F-point 330 DO jl = 1, ipl; DO jk = 1, ipk 331 ! 332 ! last khls lines (from ipj to ipj-khls+1) : full 333 DO jj = 1, khls 334 ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 335 ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 336 ! 337 DO ji = 1, khls-1 ! first khls-1 points 338 ii1 = ji ! ends at: khls-1 339 ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 340 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 341 END DO 342 DO ji = 1, 1 ! point khls 343 ii1 = khls + ji - 1 344 ii2 = ipi - ii1 345 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 346 END DO 347 DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) 348 ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 349 ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 350 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 351 END DO 352 DO ji = 1, 1 ! point ipi - khls 353 ii1 = ipi - khls + ji - 1 216 354 ii2 = ii1 217 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 218 END DO 219 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 220 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 221 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 222 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 223 END DO 224 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 225 ii1 = jpiglo - nn_hls + ji 226 ii2 = nn_hls + ji 227 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 228 END DO 229 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 230 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 231 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 232 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 233 END DO 234 END DO 235 ! 236 END DO; END DO 237 CASE ( 'F' ) ! F-point 238 DO jl = 1, ipl; DO jk = 1, ipk 239 ! 240 ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full 241 DO jj = 1, nn_hls+1 242 ij1 = ipj - jj + 1 ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls 243 ij2 = ipj - 2*nn_hls + jj - 2 ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1 244 ! 245 DO ji = 1, nn_hls ! first nn_hls points 246 ii1 = ji ! ends at: nn_hls 247 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 248 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 249 END DO 250 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 251 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 252 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 253 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 254 END DO 255 DO ji = 1, nn_hls ! last nn_hls points 256 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 257 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 258 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 259 END DO 260 END DO 261 ! 262 END DO; END DO 263 END SELECT ! NAT_IN(jf) 355 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 356 END DO 357 DO ji = 1, khls ! last khls points 358 ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi 359 ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls 360 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 361 END DO 362 END DO 363 ! 364 ! line number ipj-khls : right half 365 DO jj = 1, 1 366 ij1 = ipj - khls 367 ij2 = ij1 ! same line 368 ! 369 DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - khls-1 (note: Ni0glo = ipi - 2*khls) 370 ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls 371 ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - khls - 1 ) = khls + 1 372 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 373 END DO 374 DO ji = 1, khls-1 ! first khls-1 points: redo them just in case (if e-w periodocity already done) 375 ! ! as we just changed points ipi-2khls+1 to ipi-nn_hl-1 376 ii1 = ji ! ends at: khls 377 ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 378 ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 379 END DO 380 ! ! last khls points: have been / will done by e-w periodicity 381 END DO 382 ! 383 END DO; END DO 384 END SELECT ! cd_nat(jf) 264 385 ! 265 CASE ( 5 , 6 ) ! * North fold F-point pivot 266 ! 267 SELECT CASE ( NAT_IN(jf) ) 268 CASE ( 'T' , 'W' ) ! T-, W-point 269 DO jl = 1, ipl; DO jk = 1, ipk 270 ! 271 ! first: line number ipj-nn_hls : 3 points 272 DO jj = 1, 1 273 ij1 = ipj - nn_hls 274 ij2 = ij1 ! same line 275 ! 276 DO ji = 1, 1 ! points from jpiglo/2+1 277 ii1 = jpiglo/2 + ji 278 ii2 = jpiglo/2 - ji + 1 279 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 280 END DO 281 DO ji = 1, 1 ! points jpiglo - nn_hls 282 ii1 = jpiglo - nn_hls + ji - 1 283 ii2 = nn_hls + ji 284 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 285 END DO 286 DO ji = 1, 1 ! point nn_hls: redo it just in case (if e-w periodocity already done) 287 ! ! as we just changed point jpiglo - nn_hls 288 ii1 = nn_hls + ji - 1 289 ii2 = nn_hls + ji 290 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 291 END DO 292 END DO 293 ! 294 ! Second: last nn_hls lines (from ipj to ipj-nn_hls+1) : full 295 DO jj = 1, nn_hls 296 ij1 = ipj + 1 - jj ! ends at: ipj + 1 - nn_hls 297 ij2 = ipj - 2*nn_hls + jj ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls 298 ! 299 DO ji = 1, nn_hls ! first nn_hls points 300 ii1 = ji ! ends at: nn_hls 301 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 302 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 303 END DO 304 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 305 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 306 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 307 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 308 END DO 309 DO ji = 1, nn_hls ! last nn_hls points 310 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 311 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 312 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 313 END DO 314 END DO 315 ! 316 END DO; END DO 317 CASE ( 'U' ) ! U-point 318 DO jl = 1, ipl; DO jk = 1, ipk 319 ! 320 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 321 DO jj = 1, nn_hls 322 ij1 = ipj + 1 - jj ! ends at: ipj + 1 - nn_hls 323 ij2 = ipj - 2*nn_hls + jj ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls 324 ! 325 DO ji = 1, nn_hls-1 ! first nn_hls-1 points 326 ii1 = ji ! ends at: nn_hls-1 327 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 328 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 329 END DO 330 DO ji = 1, 1 ! point nn_hls 331 ii1 = nn_hls + ji - 1 332 ii2 = jpiglo - ii1 333 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 334 END DO 335 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 336 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 337 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 338 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 339 END DO 340 DO ji = 1, 1 ! point jpiglo - nn_hls 341 ii1 = jpiglo - nn_hls + ji - 1 342 ii2 = ii1 343 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 344 END DO 345 DO ji = 1, nn_hls ! last nn_hls points 346 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 347 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 348 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 349 END DO 350 END DO 351 ! 352 END DO; END DO 353 CASE ( 'V' ) ! V-point 354 DO jl = 1, ipl; DO jk = 1, ipk 355 ! 356 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 357 DO jj = 1, nn_hls 358 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 359 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 360 ! 361 DO ji = 1, nn_hls ! first nn_hls points 362 ii1 = ji ! ends at: nn_hls 363 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 364 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 365 END DO 366 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 367 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 368 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 369 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 370 END DO 371 DO ji = 1, nn_hls ! last nn_hls points 372 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 373 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 374 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 375 END DO 376 END DO 377 ! 378 ! line number ipj-nn_hls : right half 379 DO jj = 1, 1 380 ij1 = ipj - nn_hls 381 ij2 = ij1 ! same line 382 ! 383 DO ji = 1, Ni0glo/2 ! points from jpiglo/2+1 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 384 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 385 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 386 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 387 END DO 388 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 389 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 390 ii1 = ji ! ends at: nn_hls 391 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 392 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 393 END DO 394 ! ! last nn_hls points: have been / will done by e-w periodicity 395 END DO 396 ! 397 END DO; END DO 398 CASE ( 'F' ) ! F-point 399 DO jl = 1, ipl; DO jk = 1, ipk 400 ! 401 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 402 DO jj = 1, nn_hls 403 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 404 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 405 ! 406 DO ji = 1, nn_hls-1 ! first nn_hls-1 points 407 ii1 = ji ! ends at: nn_hls-1 408 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 409 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 410 END DO 411 DO ji = 1, 1 ! point nn_hls 412 ii1 = nn_hls + ji - 1 413 ii2 = jpiglo - ii1 414 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 415 END DO 416 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 417 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 418 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 419 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 420 END DO 421 DO ji = 1, 1 ! point jpiglo - nn_hls 422 ii1 = jpiglo - nn_hls + ji - 1 423 ii2 = ii1 424 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 425 END DO 426 DO ji = 1, nn_hls ! last nn_hls points 427 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 428 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 429 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 430 END DO 431 END DO 432 ! 433 ! line number ipj-nn_hls : right half 434 DO jj = 1, 1 435 ij1 = ipj - nn_hls 436 ij2 = ij1 ! same line 437 ! 438 DO ji = 1, Ni0glo/2-1 ! points from jpiglo/2+1 to jpiglo - nn_hls-1 (note: Ni0glo = jpiglo - 2*nn_hls) 439 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 440 ii2 = jpiglo/2 - ji ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1 ) = nn_hls + 1 441 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 442 END DO 443 DO ji = 1, nn_hls-1 ! first nn_hls-1 points: redo them just in case (if e-w periodocity already done) 444 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hl-1 445 ii1 = ji ! ends at: nn_hls 446 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 447 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 448 END DO 449 ! ! last nn_hls points: have been / will done by e-w periodicity 450 END DO 451 ! 452 END DO; END DO 453 END SELECT ! NAT_IN(jf) 454 ! 455 END SELECT ! npolj 386 ENDIF ! c_NFtype == 'F' 456 387 ! 457 388 END DO ! ipf 458 389 ! 459 END SUBROUTINE ROUTINE_NFD390 END SUBROUTINE lbc_nfd_/**/PRECISION 460 391 461 #undef PRECISION462 #undef ARRAY_TYPE463 #undef ARRAY_IN464 #undef NAT_IN465 #undef SGN_IN466 #undef J_SIZE467 #undef K_SIZE468 #undef L_SIZE469 #undef F_SIZE -
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r13286 r14574 1 #if defined MULTI 2 # define NAT_IN(k) cd_nat(k) 3 # define SGN_IN(k) psgn(k) 4 # define F_SIZE(ptab) kfld 5 # if defined DIM_2d 6 # if defined SINGLE_PRECISION 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 8 # else 9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 10 # endif 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 12 # define K_SIZE(ptab) 1 13 # define L_SIZE(ptab) 1 14 # endif 15 # if defined DIM_3d 16 # if defined SINGLE_PRECISION 17 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 18 # else 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 20 # endif 21 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 22 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 23 # define L_SIZE(ptab) 1 24 # endif 25 # if defined DIM_4d 26 # if defined SINGLE_PRECISION 27 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 28 # else 29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 30 # endif 31 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 32 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 33 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 34 # endif 35 # if defined SINGLE_PRECISION 36 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f) 37 # else 38 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f) 39 # endif 40 # define J_SIZE(ptab2) SIZE(ptab2(1)%pt4d,2) 41 # define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l) 42 #else 43 ! !== IN: ptab is an array ==! 44 # define NAT_IN(k) cd_nat 45 # define SGN_IN(k) psgn 46 # define F_SIZE(ptab) 1 47 # if defined DIM_2d 48 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 49 # define K_SIZE(ptab) 1 50 # define L_SIZE(ptab) 1 51 # endif 52 # if defined DIM_3d 53 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) 54 # define K_SIZE(ptab) SIZE(ptab,3) 55 # define L_SIZE(ptab) 1 56 # endif 57 # if defined DIM_4d 58 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) 59 # define K_SIZE(ptab) SIZE(ptab,3) 60 # define L_SIZE(ptab) SIZE(ptab,4) 61 # endif 62 # define J_SIZE(ptab2) SIZE(ptab2,2) 63 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 64 # if defined SINGLE_PRECISION 65 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 66 # define ARRAY2_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 67 # else 68 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 69 # define ARRAY2_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 70 # endif 71 # endif 72 # ifdef SINGLE_PRECISION 73 # define PRECISION sp 74 # else 75 # define PRECISION dp 76 # endif 77 SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld ) 1 2 SUBROUTINE lbc_nfd_nogather_/**/PRECISION( ptab, ptab2, cd_nat, psgn, khls ) 78 3 !!---------------------------------------------------------------------- 79 4 !! … … 82 7 !! 83 8 !!---------------------------------------------------------------------- 84 ARRAY_TYPE(:,:,:,:,:)85 ARRAY2_TYPE(:,:,:,:,:)86 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:)! nature of array grid-points87 REAL( wp) , INTENT(in ) :: SGN_IN(:)! sign used across the north fold boundary88 INTEGER , OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays89 ! 90 INTEGER :: ji, jj, jk, jn, ii, jl, jh, jf! dummy loop indices91 INTEGER :: ip i, ipj, ipk, ipl, ipf, iij, ijj! dimension of the input array9 REAL(PRECISION), DIMENSION(:,:,:,:), INTENT(inout) :: ptab ! 10 REAL(PRECISION), DIMENSION(:,:,:,:), INTENT(inout) :: ptab2 ! 11 CHARACTER(len=1) , INTENT(in ) :: cd_nat ! nature of array grid-points 12 REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold boundary 13 INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls 14 ! 15 INTEGER :: ji, jj, jk, jn, jl, jh ! dummy loop indices 16 INTEGER :: ipk, ipl, ii, iij, ijj ! dimension of the input array 92 17 INTEGER :: ijt, iju, ijta, ijua, jia, startloop, endloop 93 18 LOGICAL :: l_fast_exchanges 94 19 !!---------------------------------------------------------------------- 95 ipj = J_SIZE(ptab2) ! 2nd dimension of input array 96 ipk = K_SIZE(ptab) ! 3rd dimension of output array 97 ipl = L_SIZE(ptab) ! 4th - 98 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 99 ! 100 ! Security check for further developments 101 IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 20 ipk = SIZE(ptab,3) 21 ipl = SIZE(ptab,4) 22 ! 102 23 ! 2nd dimension determines exchange speed 103 IF (ipj == 1 ) THEN 104 l_fast_exchanges = .TRUE. 105 ELSE 106 l_fast_exchanges = .FALSE. 107 ENDIF 108 ! 109 DO jf = 1, ipf ! Loop over the number of arrays to be processed 24 l_fast_exchanges = SIZE(ptab2,2) == 1 25 ! 26 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 110 27 ! 111 SELECT CASE ( npolj ) 112 ! 113 CASE ( 3, 4 ) ! * North fold T-point pivot 114 ! 115 SELECT CASE ( NAT_IN(jf) ) 116 ! 117 CASE ( 'T' , 'W' ) ! T-, W-point 118 IF ( nimpp /= 1 ) THEN ; startloop = 1 119 ELSE ; startloop = 1 + nn_hls 120 ENDIF 121 ! 122 DO jl = 1, ipl; DO jk = 1, ipk 123 DO jj = 1, nn_hls 124 ijj = jpj -jj +1 28 SELECT CASE ( cd_nat ) 29 ! 30 CASE ( 'T' , 'W' ) ! T-, W-point 31 IF ( nimpp /= 1 ) THEN ; startloop = 1 32 ELSE ; startloop = 1 + khls 33 ENDIF 34 ! 35 DO jl = 1, ipl; DO jk = 1, ipk 36 DO jj = 1, khls 37 ijj = jpj -jj +1 38 DO ji = startloop, jpi 39 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 40 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 41 END DO 42 END DO 43 END DO; END DO 44 IF( nimpp == 1 ) THEN 45 DO jl = 1, ipl; DO jk = 1, ipk 46 DO jj = 1, khls 47 ijj = jpj -jj +1 48 DO ii = 0, khls-1 49 ptab(ii+1,ijj,jk,jl) = psgn * ptab(2*khls-ii+1,jpj-2*khls+jj-1,jk,jl) 50 END DO 51 END DO 52 END DO; END DO 53 ENDIF 54 ! 55 IF ( .NOT. l_fast_exchanges ) THEN 56 IF( nimpp >= Ni0glo/2+2 ) THEN 57 startloop = 1 58 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 59 startloop = Ni0glo/2+2 - nimpp + khls 60 ELSE 61 startloop = jpi + 1 62 ENDIF 63 IF( startloop <= jpi ) THEN 64 DO jl = 1, ipl; DO jk = 1, ipk 125 65 DO ji = startloop, jpi 126 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 127 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 128 END DO 129 END DO 130 END DO; END DO 131 IF( nimpp == 1 ) THEN 132 DO jl = 1, ipl; DO jk = 1, ipk 133 DO jj = 1, nn_hls 134 ijj = jpj -jj +1 135 DO ii = 0, nn_hls-1 136 ARRAY_IN(ii+1,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,jk,jl,jf) 137 END DO 66 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 67 jia = ji + nimpp - 1 68 ijta = jpiglo - jia + 2 69 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 70 ptab(ji,jpj-khls,jk,jl) = psgn * ptab(ijta-nimpp+khls,jpj-khls,jk,jl) 71 ELSE 72 ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(ijt,khls+1,jk,jl) 73 ENDIF 138 74 END DO 139 75 END DO; END DO 140 ENDIF 141 ! 142 IF ( .NOT. l_fast_exchanges ) THEN 143 IF( nimpp >= Ni0glo/2+2 ) THEN 144 startloop = 1 145 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 146 startloop = Ni0glo/2+2 - nimpp + nn_hls 147 ELSE 148 startloop = jpi + 1 149 ENDIF 150 IF( startloop <= jpi ) THEN 151 DO jl = 1, ipl; DO jk = 1, ipk 152 DO ji = startloop, jpi 153 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 154 jia = ji + nimpp - 1 155 ijta = jpiglo - jia + 2 156 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 157 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl,jf) 158 ELSE 159 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 160 ENDIF 161 END DO 162 END DO; END DO 163 ENDIF 164 ENDIF 165 CASE ( 'U' ) ! U-point 76 ENDIF 77 ENDIF 78 CASE ( 'U' ) ! U-point 79 IF( nimpp + jpi - 1 /= jpiglo ) THEN 80 endloop = jpi 81 ELSE 82 endloop = jpi - khls 83 ENDIF 84 DO jl = 1, ipl; DO jk = 1, ipk 85 DO jj = 1, khls 86 ijj = jpj -jj +1 87 DO ji = 1, endloop 88 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 89 ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 90 END DO 91 END DO 92 END DO; END DO 93 IF (nimpp .eq. 1) THEN 94 DO jj = 1, khls 95 ijj = jpj -jj +1 96 DO ii = 0, khls-1 97 ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls+jj-1,:,:) 98 END DO 99 END DO 100 ENDIF 101 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 102 DO jj = 1, khls 103 ijj = jpj -jj +1 104 DO ii = 1, khls 105 ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls+jj-1,:,:) 106 END DO 107 END DO 108 ENDIF 109 ! 110 IF ( .NOT. l_fast_exchanges ) THEN 166 111 IF( nimpp + jpi - 1 /= jpiglo ) THEN 167 112 endloop = jpi 168 113 ELSE 169 endloop = jpi - nn_hls 170 ENDIF 171 DO jl = 1, ipl; DO jk = 1, ipk 172 DO jj = 1, nn_hls 173 ijj = jpj -jj +1 174 DO ji = 1, endloop 175 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 176 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 177 END DO 178 END DO 179 END DO; END DO 180 IF (nimpp .eq. 1) THEN 181 DO jj = 1, nn_hls 182 ijj = jpj -jj +1 183 DO ii = 0, nn_hls-1 184 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 185 END DO 186 END DO 187 ENDIF 188 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 189 DO jj = 1, nn_hls 190 ijj = jpj -jj +1 191 DO ii = 1, nn_hls 192 ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 193 END DO 194 END DO 195 ENDIF 196 ! 197 IF ( .NOT. l_fast_exchanges ) THEN 198 IF( nimpp + jpi - 1 /= jpiglo ) THEN 199 endloop = jpi 200 ELSE 201 endloop = jpi - nn_hls 202 ENDIF 203 IF( nimpp >= Ni0glo/2+1 ) THEN 204 startloop = nn_hls 205 ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN 206 startloop = Ni0glo/2+1 - nimpp + nn_hls 207 ELSE 208 startloop = endloop + 1 209 ENDIF 210 IF( startloop <= endloop ) THEN 114 endloop = jpi - khls 115 ENDIF 116 IF( nimpp >= Ni0glo/2+1 ) THEN 117 startloop = khls 118 ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN 119 startloop = Ni0glo/2+1 - nimpp + khls 120 ELSE 121 startloop = endloop + 1 122 ENDIF 123 IF( startloop <= endloop ) THEN 211 124 DO jl = 1, ipl; DO jk = 1, ipk 212 125 DO ji = startloop, endloop … … 215 128 ijua = jpiglo - jia + 1 216 129 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 217 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl,jf)130 ptab(ji,jpj-khls,jk,jl) = psgn * ptab(ijua-nimpp+1,jpj-khls,jk,jl) 218 131 ELSE 219 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf)132 ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(iju,khls+1,jk,jl) 220 133 ENDIF 221 134 END DO 222 135 END DO; END DO 223 ENDIF 224 ENDIF 225 ! 226 CASE ( 'V' ) ! V-point 227 IF( nimpp /= 1 ) THEN 228 startloop = 1 229 ELSE 230 startloop = 1 + nn_hls 231 ENDIF 136 ENDIF 137 ENDIF 138 ! 139 CASE ( 'V' ) ! V-point 140 IF( nimpp /= 1 ) THEN 141 startloop = 1 142 ELSE 143 startloop = 1 + khls 144 ENDIF 145 IF ( .NOT. l_fast_exchanges ) THEN 146 DO jl = 1, ipl; DO jk = 1, ipk 147 DO jj = 2, khls+1 148 ijj = jpj -jj +1 149 DO ji = startloop, jpi 150 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 151 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 152 END DO 153 END DO 154 END DO; END DO 155 ENDIF 156 DO jl = 1, ipl; DO jk = 1, ipk 157 DO ji = startloop, jpi 158 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 159 ptab(ji,jpj,jk,jl) = psgn * ptab2(ijt,1,jk,jl) 160 END DO 161 END DO; END DO 162 IF (nimpp .eq. 1) THEN 163 DO jj = 1, khls 164 ijj = jpj-jj+1 165 DO ii = 0, khls-1 166 ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii+1,jpj-2*khls+jj-1,:,:) 167 END DO 168 END DO 169 ENDIF 170 CASE ( 'F' ) ! F-point 171 IF( nimpp + jpi - 1 /= jpiglo ) THEN 172 endloop = jpi 173 ELSE 174 endloop = jpi - khls 175 ENDIF 176 IF ( .NOT. l_fast_exchanges ) THEN 177 DO jl = 1, ipl; DO jk = 1, ipk 178 DO jj = 2, khls+1 179 ijj = jpj -jj +1 180 DO ji = 1, endloop 181 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 182 ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 183 END DO 184 END DO 185 END DO; END DO 186 ENDIF 187 DO jl = 1, ipl; DO jk = 1, ipk 188 DO ji = 1, endloop 189 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 190 ptab(ji,jpj,jk,jl) = psgn * ptab2(iju,1,jk,jl) 191 END DO 192 END DO; END DO 193 IF (nimpp .eq. 1) THEN 194 DO ii = 1, khls 195 ptab(ii,jpj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls-1,:,:) 196 END DO 232 197 IF ( .NOT. l_fast_exchanges ) THEN 198 DO jj = 1, khls 199 ijj = jpj -jj 200 DO ii = 0, khls-1 201 ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls+jj-1,:,:) 202 END DO 203 END DO 204 ENDIF 205 ENDIF 206 IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 207 DO ii = 1, khls 208 ptab(jpi-ii+1,jpj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls-1,:,:) 209 END DO 210 IF ( .NOT. l_fast_exchanges ) THEN 211 DO jj = 1, khls 212 ijj = jpj -jj 213 DO ii = 1, khls 214 ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls+jj-1,:,:) 215 END DO 216 END DO 217 ENDIF 218 ENDIF 219 ! 220 END SELECT 221 ! 222 ENDIF ! c_NFtype == 'T' 223 ! 224 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 225 ! 226 SELECT CASE ( cd_nat ) 227 CASE ( 'T' , 'W' ) ! T-, W-point 228 DO jl = 1, ipl; DO jk = 1, ipk 229 DO jj = 1, khls 230 ijj = jpj-jj+1 231 DO ji = 1, jpi 232 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 233 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 234 END DO 235 END DO 236 END DO; END DO 237 ! 238 CASE ( 'U' ) ! U-point 239 IF( nimpp + jpi - 1 /= jpiglo ) THEN 240 endloop = jpi 241 ELSE 242 endloop = jpi - khls 243 ENDIF 244 DO jl = 1, ipl; DO jk = 1, ipk 245 DO jj = 1, khls 246 ijj = jpj-jj+1 247 DO ji = 1, endloop 248 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 249 ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 250 END DO 251 END DO 252 END DO; END DO 253 IF(nimpp + jpi - 1 .eq. jpiglo) THEN 254 DO jl = 1, ipl; DO jk = 1, ipk 255 DO jj = 1, khls 256 ijj = jpj-jj+1 257 DO ii = 1, khls 258 iij = jpi-ii+1 259 ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*khls+ii-1,jpj-2*khls+jj,jk,jl) 260 END DO 261 END DO 262 END DO; END DO 263 ENDIF 264 ! 265 CASE ( 'V' ) ! V-point 266 DO jl = 1, ipl; DO jk = 1, ipk 267 DO jj = 1, khls 268 ijj = jpj -jj +1 269 DO ji = 1, jpi 270 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 271 ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 272 END DO 273 END DO 274 END DO; END DO 275 276 IF ( .NOT. l_fast_exchanges ) THEN 277 IF( nimpp >= Ni0glo/2+2 ) THEN 278 startloop = 1 279 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 280 startloop = Ni0glo/2+2 - nimpp + khls 281 ELSE 282 startloop = jpi + 1 283 ENDIF 284 IF( startloop <= jpi ) THEN 233 285 DO jl = 1, ipl; DO jk = 1, ipk 234 DO jj = 2, nn_hls+1 235 ijj = jpj -jj +1 236 DO ji = startloop, jpi 237 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 238 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 239 END DO 240 END DO 286 DO ji = startloop, jpi 287 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 288 ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(ijt,khls+1,jk,jl) 289 END DO 241 290 END DO; END DO 242 291 ENDIF 243 DO jl = 1, ipl; DO jk = 1, ipk 244 DO ji = startloop, jpi 245 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 246 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf) 247 END DO 248 END DO; END DO 249 IF (nimpp .eq. 1) THEN 250 DO jj = 1, nn_hls 251 ijj = jpj-jj+1 252 DO ii = 0, nn_hls-1 253 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:,jf) 254 END DO 255 END DO 256 ENDIF 257 CASE ( 'F' ) ! F-point 292 ENDIF 293 ! 294 CASE ( 'F' ) ! F-point 295 IF( nimpp + jpi - 1 /= jpiglo ) THEN 296 endloop = jpi 297 ELSE 298 endloop = jpi - khls 299 ENDIF 300 DO jl = 1, ipl; DO jk = 1, ipk 301 DO jj = 1, khls 302 ijj = jpj -jj +1 303 DO ji = 1, endloop 304 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 305 ptab(ji,ijj ,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 306 END DO 307 END DO 308 END DO; END DO 309 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 310 DO jl = 1, ipl; DO jk = 1, ipk 311 DO jj = 1, khls 312 ijj = jpj -jj +1 313 DO ii = 1, khls 314 iij = jpi -ii+1 315 ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*khls+ii-1,jpj-2*khls+jj-1,jk,jl) 316 END DO 317 END DO 318 END DO; END DO 319 ENDIF 320 ! 321 IF ( .NOT. l_fast_exchanges ) THEN 258 322 IF( nimpp + jpi - 1 /= jpiglo ) THEN 259 323 endloop = jpi 260 324 ELSE 261 endloop = jpi - nn_hls 262 ENDIF 263 IF ( .NOT. l_fast_exchanges ) THEN 325 endloop = jpi - khls 326 ENDIF 327 IF( nimpp >= Ni0glo/2+2 ) THEN 328 startloop = 1 329 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 330 startloop = Ni0glo/2+2 - nimpp + khls 331 ELSE 332 startloop = endloop + 1 333 ENDIF 334 IF( startloop <= endloop ) THEN 264 335 DO jl = 1, ipl; DO jk = 1, ipk 265 DO jj = 2, nn_hls+1 266 ijj = jpj -jj +1 267 DO ji = 1, endloop 268 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 269 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 270 END DO 271 END DO 336 DO ji = startloop, endloop 337 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 338 ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(iju,khls+1,jk,jl) 339 END DO 272 340 END DO; END DO 273 341 ENDIF 274 DO jl = 1, ipl; DO jk = 1, ipk 275 DO ji = 1, endloop 276 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 277 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf) 278 END DO 279 END DO; END DO 280 IF (nimpp .eq. 1) THEN 281 DO ii = 1, nn_hls 282 ARRAY_IN(ii,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:,jf) 283 END DO 284 IF ( .NOT. l_fast_exchanges ) THEN 285 DO jj = 1, nn_hls 286 ijj = jpj -jj 287 DO ii = 0, nn_hls-1 288 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 289 END DO 290 END DO 291 ENDIF 292 ENDIF 293 IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 294 DO ii = 1, nn_hls 295 ARRAY_IN(jpi-ii+1,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:,jf) 296 END DO 297 IF ( .NOT. l_fast_exchanges ) THEN 298 DO jj = 1, nn_hls 299 ijj = jpj -jj 300 DO ii = 1, nn_hls 301 ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 302 END DO 303 END DO 304 ENDIF 305 ENDIF 306 ! 307 END SELECT 308 ! 309 CASE ( 5, 6 ) ! * North fold F-point pivot 310 ! 311 SELECT CASE ( NAT_IN(jf) ) 312 CASE ( 'T' , 'W' ) ! T-, W-point 313 DO jl = 1, ipl; DO jk = 1, ipk 314 DO jj = 1, nn_hls 315 ijj = jpj-jj+1 316 DO ji = 1, jpi 317 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 318 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 319 END DO 320 END DO 321 END DO; END DO 322 ! 323 CASE ( 'U' ) ! U-point 324 IF( nimpp + jpi - 1 /= jpiglo ) THEN 325 endloop = jpi 326 ELSE 327 endloop = jpi - nn_hls 328 ENDIF 329 DO jl = 1, ipl; DO jk = 1, ipk 330 DO jj = 1, nn_hls 331 ijj = jpj-jj+1 332 DO ji = 1, endloop 333 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 334 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 335 END DO 336 END DO 337 END DO; END DO 338 IF(nimpp + jpi - 1 .eq. jpiglo) THEN 339 DO jl = 1, ipl; DO jk = 1, ipk 340 DO jj = 1, nn_hls 341 ijj = jpj-jj+1 342 DO ii = 1, nn_hls 343 iij = jpi-ii+1 344 ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl,jf) 345 END DO 346 END DO 347 END DO; END DO 348 ENDIF 349 ! 350 CASE ( 'V' ) ! V-point 351 DO jl = 1, ipl; DO jk = 1, ipk 352 DO jj = 1, nn_hls 353 ijj = jpj -jj +1 354 DO ji = 1, jpi 355 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 356 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 357 END DO 358 END DO 359 END DO; END DO 342 ENDIF 343 ! 344 END SELECT 345 ! 346 ENDIF ! c_NFtype == 'F' 347 ! 348 END SUBROUTINE lbc_nfd_nogather_/**/PRECISION 360 349 361 IF ( .NOT. l_fast_exchanges ) THEN362 IF( nimpp >= Ni0glo/2+2 ) THEN363 startloop = 1364 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN365 startloop = Ni0glo/2+2 - nimpp + nn_hls366 ELSE367 startloop = jpi + 1368 ENDIF369 IF( startloop <= jpi ) THEN370 DO jl = 1, ipl; DO jk = 1, ipk371 DO ji = startloop, jpi372 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3373 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf)374 END DO375 END DO; END DO376 ENDIF377 ENDIF378 !379 CASE ( 'F' ) ! F-point380 IF( nimpp + jpi - 1 /= jpiglo ) THEN381 endloop = jpi382 ELSE383 endloop = jpi - nn_hls384 ENDIF385 DO jl = 1, ipl; DO jk = 1, ipk386 DO jj = 1, nn_hls387 ijj = jpj -jj +1388 DO ji = 1, endloop389 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2390 ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)391 END DO392 END DO393 END DO; END DO394 IF((nimpp + jpi - 1) .eq. jpiglo) THEN395 DO jl = 1, ipl; DO jk = 1, ipk396 DO jj = 1, nn_hls397 ijj = jpj -jj +1398 DO ii = 1, nn_hls399 iij = jpi -ii+1400 ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl,jf)401 END DO402 END DO403 END DO; END DO404 ENDIF405 !406 IF ( .NOT. l_fast_exchanges ) THEN407 IF( nimpp + jpi - 1 /= jpiglo ) THEN408 endloop = jpi409 ELSE410 endloop = jpi - nn_hls411 ENDIF412 IF( nimpp >= Ni0glo/2+2 ) THEN413 startloop = 1414 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN415 startloop = Ni0glo/2+2 - nimpp + nn_hls416 ELSE417 startloop = endloop + 1418 ENDIF419 IF( startloop <= endloop ) THEN420 DO jl = 1, ipl; DO jk = 1, ipk421 DO ji = startloop, endloop422 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2423 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf)424 END DO425 END DO; END DO426 ENDIF427 ENDIF428 !429 END SELECT430 !431 CASE DEFAULT ! * closed : the code probably never go through432 !433 WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj434 !435 END SELECT ! npolj436 !437 END DO ! End jf loop438 END SUBROUTINE ROUTINE_NFD439 #undef PRECISION440 #undef ARRAY_TYPE441 #undef ARRAY_IN442 #undef NAT_IN443 #undef SGN_IN444 #undef J_SIZE445 #undef K_SIZE446 #undef L_SIZE447 #undef F_SIZE448 #undef ARRAY2_TYPE449 #undef ARRAY2_IN -
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lbclnk.F90
r14229 r14574 23 23 USE lbcnfd ! north fold 24 24 USE in_out_manager ! I/O manager 25 #if ! defined key_mpi_off 26 USE MPI 27 #endif 25 28 26 29 IMPLICIT NONE … … 28 31 29 32 INTERFACE lbc_lnk 30 MODULE PROCEDURE mpp_lnk_2d_sp , mpp_lnk_3d_sp , mpp_lnk_4d_sp 31 MODULE PROCEDURE mpp_lnk_2d_dp , mpp_lnk_3d_dp , mpp_lnk_4d_dp 32 END INTERFACE 33 INTERFACE lbc_lnk_ptr 34 MODULE PROCEDURE mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp 35 MODULE PROCEDURE mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp 36 END INTERFACE 37 INTERFACE lbc_lnk_multi 38 MODULE PROCEDURE lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp 39 MODULE PROCEDURE lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 40 END INTERFACE 41 INTERFACE lbc_lnk_nc_multi 42 MODULE PROCEDURE lbc_lnk_nc_2d_sp, lbc_lnk_nc_3d_sp, lbc_lnk_nc_4d_sp 43 MODULE PROCEDURE lbc_lnk_nc_2d_dp, lbc_lnk_nc_3d_dp, lbc_lnk_nc_4d_dp 44 END INTERFACE 45 INTERFACE lbc_lnk_nc 46 MODULE PROCEDURE mpp_lnk_nc_2d_sp, mpp_lnk_nc_3d_sp, mpp_lnk_nc_4d_sp 47 MODULE PROCEDURE mpp_lnk_nc_2d_dp, mpp_lnk_nc_3d_dp, mpp_lnk_nc_4d_dp 33 MODULE PROCEDURE lbc_lnk_call_2d_sp, lbc_lnk_call_3d_sp, lbc_lnk_call_4d_sp 34 MODULE PROCEDURE lbc_lnk_call_2d_dp, lbc_lnk_call_3d_dp, lbc_lnk_call_4d_dp 35 END INTERFACE 36 37 INTERFACE lbc_lnk_pt2pt 38 MODULE PROCEDURE lbc_lnk_pt2pt_sp, lbc_lnk_pt2pt_dp 39 END INTERFACE 40 41 INTERFACE lbc_lnk_neicoll 42 MODULE PROCEDURE lbc_lnk_neicoll_sp ,lbc_lnk_neicoll_dp 48 43 END INTERFACE 49 44 ! … … 52 47 END INTERFACE 53 48 54 INTERFACE mpp_nfd55 MODULE PROCEDURE mpp_nfd_2d_sp , mpp_nfd_3d_sp , mpp_nfd_4d_sp56 MODULE PROCEDURE mpp_nfd_2d_dp , mpp_nfd_3d_dp , mpp_nfd_4d_dp57 MODULE PROCEDURE mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp58 MODULE PROCEDURE mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp59 60 END INTERFACE61 62 49 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 63 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions64 50 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 65 PUBLIC lbc_lnk_nc ! ocean/ice lateral boundary conditions (MPI3 version) 66 PUBLIC lbc_lnk_nc_multi ! modified ocean/ice lateral boundary conditions (MPI3 version) 67 68 #if ! defined key_mpi_off 69 !$AGRIF_DO_NOT_TREAT 70 INCLUDE 'mpif.h' 71 !$AGRIF_END_DO_NOT_TREAT 72 #endif 73 74 INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 75 INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 76 INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 77 INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 78 INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 79 51 52 REAL(dp), DIMENSION(:), ALLOCATABLE :: buffsnd_dp, buffrcv_dp ! MPI send/recv buffers 53 REAL(sp), DIMENSION(:), ALLOCATABLE :: buffsnd_sp, buffrcv_sp ! 54 INTEGER, DIMENSION(8) :: nreq_p2p ! request id for MPI_Isend in point-2-point communication 55 80 56 !! * Substitutions 81 # include "do_loop_substitute.h90"57 !!# include "do_loop_substitute.h90" 82 58 !!---------------------------------------------------------------------- 83 59 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 88 64 89 65 !!---------------------------------------------------------------------- 90 !! *** l oad_ptr_(2,3,4)d***66 !! *** lbc_lnk_call_[234]d_[sd]p *** 91 67 !! 92 68 !! * Dummy Argument : 93 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 69 !! in ==> cdname ! name of the calling subroutine (for monitoring) 70 !! ptab ! array to be loaded (2D, 3D or 4D) 94 71 !! cd_nat ! nature of pt2d array grid-points 95 72 !! psgn ! sign used across the north fold boundary … … 99 76 !! kfld ! number of elements that has been attributed 100 77 !!---------------------------------------------------------------------- 101 102 !!---------------------------------------------------------------------- 103 !! *** lbc_lnk_(2,3,4)d_multi *** 104 !! *** load_ptr_(2,3,4)d *** 105 !! 106 !! * Argument : dummy argument use in lbc_lnk_multi_... routines 107 !! 108 !!---------------------------------------------------------------------- 109 78 ! 79 !!---------------------------------------------------------------------- 80 !! 81 !! *** lbc_lnk_call_[234]d_[sd]p *** 82 !! *** load_ptr_[234]d_[sd]p *** 83 !! 84 !!---------------------------------------------------------------------- 110 85 !! 111 86 !! ---- SINGLE PRECISION VERSIONS 112 87 !! 113 # define SINGLE_PRECISION 114 # define DIM_2d 115 # define ROUTINE_LOAD load_ptr_2d_sp 116 # define ROUTINE_MULTI lbc_lnk_2d_multi_sp 117 # include "lbc_lnk_multi_generic.h90" 118 # undef ROUTINE_MULTI 119 # undef ROUTINE_LOAD 120 # undef DIM_2d 121 122 # define DIM_3d 123 # define ROUTINE_LOAD load_ptr_3d_sp 124 # define ROUTINE_MULTI lbc_lnk_3d_multi_sp 125 # include "lbc_lnk_multi_generic.h90" 126 # undef ROUTINE_MULTI 127 # undef ROUTINE_LOAD 128 # undef DIM_3d 129 130 # define DIM_4d 131 # define ROUTINE_LOAD load_ptr_4d_sp 132 # define ROUTINE_MULTI lbc_lnk_4d_multi_sp 133 # include "lbc_lnk_multi_generic.h90" 134 # undef ROUTINE_MULTI 135 # undef ROUTINE_LOAD 136 # undef DIM_4d 137 # undef SINGLE_PRECISION 88 #define PRECISION sp 89 # define DIM_2d 90 # include "lbc_lnk_call_generic.h90" 91 # undef DIM_2d 92 # define DIM_3d 93 # include "lbc_lnk_call_generic.h90" 94 # undef DIM_3d 95 # define DIM_4d 96 # include "lbc_lnk_call_generic.h90" 97 # undef DIM_4d 98 #undef PRECISION 138 99 !! 139 100 !! ---- DOUBLE PRECISION VERSIONS 140 101 !! 141 142 # define DIM_2d 143 # define ROUTINE_LOAD load_ptr_2d_dp 144 # define ROUTINE_MULTI lbc_lnk_2d_multi_dp 145 # include "lbc_lnk_multi_generic.h90" 146 # undef ROUTINE_MULTI 147 # undef ROUTINE_LOAD 148 # undef DIM_2d 149 150 # define DIM_3d 151 # define ROUTINE_LOAD load_ptr_3d_dp 152 # define ROUTINE_MULTI lbc_lnk_3d_multi_dp 153 # include "lbc_lnk_multi_generic.h90" 154 # undef ROUTINE_MULTI 155 # undef ROUTINE_LOAD 156 # undef DIM_3d 157 158 # define DIM_4d 159 # define ROUTINE_LOAD load_ptr_4d_dp 160 # define ROUTINE_MULTI lbc_lnk_4d_multi_dp 161 # include "lbc_lnk_multi_generic.h90" 162 # undef ROUTINE_MULTI 163 # undef ROUTINE_LOAD 164 # undef DIM_4d 165 166 !!---------------------------------------------------------------------- 167 !! *** routine mpp_lnk_(2,3,4)d *** 168 !! 169 !! * Argument : dummy argument use in mpp_lnk_... routines 170 !! ptab : array or pointer of arrays on which the boundary condition is applied 102 #define PRECISION dp 103 # define DIM_2d 104 # include "lbc_lnk_call_generic.h90" 105 # undef DIM_2d 106 # define DIM_3d 107 # include "lbc_lnk_call_generic.h90" 108 # undef DIM_3d 109 # define DIM_4d 110 # include "lbc_lnk_call_generic.h90" 111 # undef DIM_4d 112 #undef PRECISION 113 ! 114 !!---------------------------------------------------------------------- 115 !! *** lbc_lnk_pt2pt_[sd]p *** 116 !! *** lbc_lnk_neicoll_[sd]p *** 117 !! 118 !! * Argument : dummy argument use in lbc_lnk_... routines 119 !! cdname : name of the calling subroutine (for monitoring) 120 !! ptab : pointer of arrays on which the boundary condition is applied 171 121 !! cd_nat : nature of array grid-points 172 122 !! psgn : sign used across the north fold boundary 173 !! kfld : optional,number of pt3d arrays123 !! kfld : number of pt3d arrays 174 124 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 175 125 !! pfillval : optional, background value (used with jpfillcopy) 176 126 !!---------------------------------------------------------------------- 177 !178 ! !== 2D array and array of 2D pointer ==!179 !180 127 !! 181 128 !! ---- SINGLE PRECISION VERSIONS 182 129 !! 183 # define SINGLE_PRECISION 184 # define DIM_2d 185 # define ROUTINE_LNK mpp_lnk_2d_sp 186 # include "mpp_lnk_generic.h90" 187 # undef ROUTINE_LNK 188 # define MULTI 189 # define ROUTINE_LNK mpp_lnk_2d_ptr_sp 190 # include "mpp_lnk_generic.h90" 191 # undef ROUTINE_LNK 192 # undef MULTI 193 # undef DIM_2d 194 ! 195 ! !== 3D array and array of 3D pointer ==! 196 ! 197 # define DIM_3d 198 # define ROUTINE_LNK mpp_lnk_3d_sp 199 # include "mpp_lnk_generic.h90" 200 # undef ROUTINE_LNK 201 # define MULTI 202 # define ROUTINE_LNK mpp_lnk_3d_ptr_sp 203 # include "mpp_lnk_generic.h90" 204 # undef ROUTINE_LNK 205 # undef MULTI 206 # undef DIM_3d 207 ! 208 ! !== 4D array and array of 4D pointer ==! 209 ! 210 # define DIM_4d 211 # define ROUTINE_LNK mpp_lnk_4d_sp 212 # include "mpp_lnk_generic.h90" 213 # undef ROUTINE_LNK 214 # define MULTI 215 # define ROUTINE_LNK mpp_lnk_4d_ptr_sp 216 # include "mpp_lnk_generic.h90" 217 # undef ROUTINE_LNK 218 # undef MULTI 219 # undef DIM_4d 220 # undef SINGLE_PRECISION 221 130 #define PRECISION sp 131 # define MPI_TYPE MPI_REAL 132 # define BUFFSND buffsnd_sp 133 # define BUFFRCV buffrcv_sp 134 # include "lbc_lnk_pt2pt_generic.h90" 135 # include "lbc_lnk_neicoll_generic.h90" 136 # undef MPI_TYPE 137 # undef BUFFSND 138 # undef BUFFRCV 139 #undef PRECISION 222 140 !! 223 141 !! ---- DOUBLE PRECISION VERSIONS 224 142 !! 225 # define DIM_2d 226 # define ROUTINE_LNK mpp_lnk_2d_dp 227 # include "mpp_lnk_generic.h90" 228 # undef ROUTINE_LNK 229 # define MULTI 230 # define ROUTINE_LNK mpp_lnk_2d_ptr_dp 231 # include "mpp_lnk_generic.h90" 232 # undef ROUTINE_LNK 233 # undef MULTI 234 # undef DIM_2d 235 ! 236 ! !== 3D array and array of 3D pointer ==! 237 ! 238 # define DIM_3d 239 # define ROUTINE_LNK mpp_lnk_3d_dp 240 # include "mpp_lnk_generic.h90" 241 # undef ROUTINE_LNK 242 # define MULTI 243 # define ROUTINE_LNK mpp_lnk_3d_ptr_dp 244 # include "mpp_lnk_generic.h90" 245 # undef ROUTINE_LNK 246 # undef MULTI 247 # undef DIM_3d 248 ! 249 ! !== 4D array and array of 4D pointer ==! 250 ! 251 # define DIM_4d 252 # define ROUTINE_LNK mpp_lnk_4d_dp 253 # include "mpp_lnk_generic.h90" 254 # undef ROUTINE_LNK 255 # define MULTI 256 # define ROUTINE_LNK mpp_lnk_4d_ptr_dp 257 # include "mpp_lnk_generic.h90" 258 # undef ROUTINE_LNK 259 # undef MULTI 260 # undef DIM_4d 261 262 !!---------------------------------------------------------------------- 263 !! *** load_ptr_(2,3,4)d *** 264 !! 265 !! * Dummy Argument : 266 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 267 !! cd_nat ! nature of pt2d array grid-points 268 !! psgn ! sign used across the north fold boundary 269 !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers 270 !! cdna_ptr ! nature of ptab array grid-points 271 !! psgn_ptr ! sign used across the north fold boundary 272 !! kfld ! number of elements that has been attributed 273 !!---------------------------------------------------------------------- 274 275 !!---------------------------------------------------------------------- 276 !! *** lbc_lnk_nc(2,3,4)d_multi *** 277 !! *** load_ptr_(2,3,4)d *** 278 !! 279 !! * Argument : dummy argument use in lbc_lnk_nc_multi_... routines 280 !! 281 !!---------------------------------------------------------------------- 282 283 !! 284 !! ---- SINGLE PRECISION VERSIONS 285 !! 286 # define SINGLE_PRECISION 287 # define DIM_2d 288 # define ROUTINE_NC_LOAD load_ptr_nc_2d_sp 289 # define ROUTINE_MULTI_NC lbc_lnk_nc_2d_sp 290 # include "lbc_lnk_nc_generic.h90" 291 # undef ROUTINE_MULTI_NC 292 # undef ROUTINE_NC_LOAD 293 # undef DIM_2d 294 295 # define DIM_3d 296 # define ROUTINE_NC_LOAD load_ptr_nc_3d_sp 297 # define ROUTINE_MULTI_NC lbc_lnk_nc_3d_sp 298 # include "lbc_lnk_nc_generic.h90" 299 # undef ROUTINE_MULTI_NC 300 # undef ROUTINE_NC_LOAD 301 # undef DIM_3d 302 303 # define DIM_4d 304 # define ROUTINE_NC_LOAD load_ptr_nc_4d_sp 305 # define ROUTINE_MULTI_NC lbc_lnk_nc_4d_sp 306 # include "lbc_lnk_nc_generic.h90" 307 # undef ROUTINE_MULTI_NC 308 # undef ROUTINE_NC_LOAD 309 # undef DIM_4d 310 # undef SINGLE_PRECISION 311 !! 312 !! ---- DOUBLE PRECISION VERSIONS 313 !! 314 315 # define DIM_2d 316 # define ROUTINE_NC_LOAD load_ptr_nc_2d_dp 317 # define ROUTINE_MULTI_NC lbc_lnk_nc_2d_dp 318 # include "lbc_lnk_nc_generic.h90" 319 # undef ROUTINE_MULTI_NC 320 # undef ROUTINE_NC_LOAD 321 # undef DIM_2d 322 323 # define DIM_3d 324 # define ROUTINE_NC_LOAD load_ptr_nc_3d_dp 325 # define ROUTINE_MULTI_NC lbc_lnk_nc_3d_dp 326 # include "lbc_lnk_nc_generic.h90" 327 # undef ROUTINE_MULTI_NC 328 # undef ROUTINE_NC_LOAD 329 # undef DIM_3d 330 331 # define DIM_4d 332 # define ROUTINE_NC_LOAD load_ptr_nc_4d_dp 333 # define ROUTINE_MULTI_NC lbc_lnk_nc_4d_dp 334 # include "lbc_lnk_nc_generic.h90" 335 # undef ROUTINE_MULTI_NC 336 # undef ROUTINE_NC_LOAD 337 # undef DIM_4d 338 339 !!---------------------------------------------------------------------- 340 !! *** routine mpp_lnk_nc_(2,3,4)d *** 341 !! 342 !! * Argument : dummy argument use in mpp_lnk_... routines 343 !! ptab : array or pointer of arrays on which the boundary condition is applied 344 !! cd_nat : nature of array grid-points 345 !! psgn : sign used across the north fold boundary 346 !! kfld : optional, number of pt3d arrays 347 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 348 !! pfillval : optional, background value (used with jpfillcopy) 349 !!---------------------------------------------------------------------- 350 ! 351 ! !== 2D array and array of 2D pointer ==! 352 ! 353 !! 354 !! ---- SINGLE PRECISION VERSIONS 355 !! 356 # define SINGLE_PRECISION 357 # define DIM_2d 358 # define ROUTINE_NC mpp_lnk_nc_2d_sp 359 # include "mpp_nc_generic.h90" 360 # undef ROUTINE_NC 361 # undef DIM_2d 362 ! 363 ! !== 3D array and array of 3D pointer ==! 364 ! 365 # define DIM_3d 366 # define ROUTINE_NC mpp_lnk_nc_3d_sp 367 # include "mpp_nc_generic.h90" 368 # undef ROUTINE_NC 369 # undef DIM_3d 370 ! 371 ! !== 4D array and array of 4D pointer ==! 372 ! 373 # define DIM_4d 374 # define ROUTINE_NC mpp_lnk_nc_4d_sp 375 # include "mpp_nc_generic.h90" 376 # undef ROUTINE_NC 377 # undef DIM_4d 378 # undef SINGLE_PRECISION 379 380 !! 381 !! ---- DOUBLE PRECISION VERSIONS 382 !! 383 # define DIM_2d 384 # define ROUTINE_NC mpp_lnk_nc_2d_dp 385 # include "mpp_nc_generic.h90" 386 # undef ROUTINE_NC 387 # undef DIM_2d 388 ! 389 ! !== 3D array and array of 3D pointer ==! 390 ! 391 # define DIM_3d 392 # define ROUTINE_NC mpp_lnk_nc_3d_dp 393 # include "mpp_nc_generic.h90" 394 # undef ROUTINE_NC 395 # undef DIM_3d 396 ! 397 ! !== 4D array and array of 4D pointer ==! 398 ! 399 # define DIM_4d 400 # define ROUTINE_NC mpp_lnk_nc_4d_dp 401 # include "mpp_nc_generic.h90" 402 # undef ROUTINE_NC 403 # undef DIM_4d 404 405 !!---------------------------------------------------------------------- 406 !! *** routine mpp_nfd_(2,3,4)d *** 407 !! 408 !! * Argument : dummy argument use in mpp_nfd_... routines 409 !! ptab : array or pointer of arrays on which the boundary condition is applied 410 !! cd_nat : nature of array grid-points 411 !! psgn : sign used across the north fold boundary 412 !! kfld : optional, number of pt3d arrays 413 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 414 !! pfillval : optional, background value (used with jpfillcopy) 415 !!---------------------------------------------------------------------- 416 ! 417 ! !== 2D array and array of 2D pointer ==! 418 ! 419 !! 420 !! ---- SINGLE PRECISION VERSIONS 421 !! 422 # define SINGLE_PRECISION 423 # define DIM_2d 424 # define ROUTINE_NFD mpp_nfd_2d_sp 425 # include "mpp_nfd_generic.h90" 426 # undef ROUTINE_NFD 427 # define MULTI 428 # define ROUTINE_NFD mpp_nfd_2d_ptr_sp 429 # include "mpp_nfd_generic.h90" 430 # undef ROUTINE_NFD 431 # undef MULTI 432 # undef DIM_2d 433 ! 434 ! !== 3D array and array of 3D pointer ==! 435 ! 436 # define DIM_3d 437 # define ROUTINE_NFD mpp_nfd_3d_sp 438 # include "mpp_nfd_generic.h90" 439 # undef ROUTINE_NFD 440 # define MULTI 441 # define ROUTINE_NFD mpp_nfd_3d_ptr_sp 442 # include "mpp_nfd_generic.h90" 443 # undef ROUTINE_NFD 444 # undef MULTI 445 # undef DIM_3d 446 ! 447 ! !== 4D array and array of 4D pointer ==! 448 ! 449 # define DIM_4d 450 # define ROUTINE_NFD mpp_nfd_4d_sp 451 # include "mpp_nfd_generic.h90" 452 # undef ROUTINE_NFD 453 # define MULTI 454 # define ROUTINE_NFD mpp_nfd_4d_ptr_sp 455 # include "mpp_nfd_generic.h90" 456 # undef ROUTINE_NFD 457 # undef MULTI 458 # undef DIM_4d 459 # undef SINGLE_PRECISION 460 461 !! 462 !! ---- DOUBLE PRECISION VERSIONS 463 !! 464 # define DIM_2d 465 # define ROUTINE_NFD mpp_nfd_2d_dp 466 # include "mpp_nfd_generic.h90" 467 # undef ROUTINE_NFD 468 # define MULTI 469 # define ROUTINE_NFD mpp_nfd_2d_ptr_dp 470 # include "mpp_nfd_generic.h90" 471 # undef ROUTINE_NFD 472 # undef MULTI 473 # undef DIM_2d 474 ! 475 ! !== 3D array and array of 3D pointer ==! 476 ! 477 # define DIM_3d 478 # define ROUTINE_NFD mpp_nfd_3d_dp 479 # include "mpp_nfd_generic.h90" 480 # undef ROUTINE_NFD 481 # define MULTI 482 # define ROUTINE_NFD mpp_nfd_3d_ptr_dp 483 # include "mpp_nfd_generic.h90" 484 # undef ROUTINE_NFD 485 # undef MULTI 486 # undef DIM_3d 487 ! 488 ! !== 4D array and array of 4D pointer ==! 489 ! 490 # define DIM_4d 491 # define ROUTINE_NFD mpp_nfd_4d_dp 492 # include "mpp_nfd_generic.h90" 493 # undef ROUTINE_NFD 494 # define MULTI 495 # define ROUTINE_NFD mpp_nfd_4d_ptr_dp 496 # include "mpp_nfd_generic.h90" 497 # undef ROUTINE_NFD 498 # undef MULTI 499 # undef DIM_4d 500 501 !!====================================================================== 502 143 #define PRECISION dp 144 # define MPI_TYPE MPI_DOUBLE_PRECISION 145 # define BUFFSND buffsnd_dp 146 # define BUFFRCV buffrcv_dp 147 # include "lbc_lnk_pt2pt_generic.h90" 148 # include "lbc_lnk_neicoll_generic.h90" 149 # undef MPI_TYPE 150 # undef BUFFSND 151 # undef BUFFRCV 152 #undef PRECISION 503 153 504 154 !!====================================================================== … … 541 191 !! jpi : first dimension of the local subdomain 542 192 !! jpj : second dimension of the local subdomain 543 !! kexti : number of columns for extra outer halo 544 !! kextj : number of rows for extra outer halo 545 !! nbondi : mark for "east-west local boundary" 546 !! nbondj : mark for "north-south local boundary" 547 !! noea : number for local neighboring processors 548 !! nowe : number for local neighboring processors 549 !! noso : number for local neighboring processors 550 !! nono : number for local neighboring processors 193 !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 551 194 !!---------------------------------------------------------------------- 552 195 -
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lbcnfd.F90
r13286 r14574 21 21 USE in_out_manager ! I/O manager 22 22 USE lib_mpp ! MPP library 23 #if ! defined key_mpi_off 24 USE MPI 25 #endif 23 26 24 27 IMPLICIT NONE 25 28 PRIVATE 26 29 27 INTERFACE lbc_nfd 28 MODULE PROCEDURE lbc_nfd_2d_sp , lbc_nfd_3d_sp , lbc_nfd_4d_sp 29 MODULE PROCEDURE lbc_nfd_2d_ptr_sp, lbc_nfd_3d_ptr_sp, lbc_nfd_4d_ptr_sp 30 MODULE PROCEDURE lbc_nfd_2d_ext_sp 31 MODULE PROCEDURE lbc_nfd_2d_dp , lbc_nfd_3d_dp , lbc_nfd_4d_dp 32 MODULE PROCEDURE lbc_nfd_2d_ptr_dp, lbc_nfd_3d_ptr_dp, lbc_nfd_4d_ptr_dp 33 MODULE PROCEDURE lbc_nfd_2d_ext_dp 34 END INTERFACE 35 ! 36 INTERFACE lbc_nfd_nogather 37 ! ! Currently only 4d array version is needed 38 MODULE PROCEDURE lbc_nfd_nogather_2d_sp , lbc_nfd_nogather_3d_sp 39 MODULE PROCEDURE lbc_nfd_nogather_4d_sp 40 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_sp, lbc_nfd_nogather_3d_ptr_sp 41 MODULE PROCEDURE lbc_nfd_nogather_2d_dp , lbc_nfd_nogather_3d_dp 42 MODULE PROCEDURE lbc_nfd_nogather_4d_dp 43 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_dp, lbc_nfd_nogather_3d_ptr_dp 44 ! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr 30 INTERFACE lbc_nfd ! called by mpp_nfd, lbc_lnk_pt2pt or lbc_lnk_neicoll 31 MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_ext_sp 32 MODULE PROCEDURE lbc_nfd_dp, lbc_nfd_ext_dp 45 33 END INTERFACE 46 34 47 TYPE, PUBLIC :: PTR_2D_dp !: array of 2D pointers (also used in lib_mpp) 48 REAL(dp), DIMENSION (:,:) , POINTER :: pt2d 49 END TYPE PTR_2D_dp 50 TYPE, PUBLIC :: PTR_3D_dp !: array of 3D pointers (also used in lib_mpp) 51 REAL(dp), DIMENSION (:,:,:) , POINTER :: pt3d 52 END TYPE PTR_3D_dp 53 TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (also used in lib_mpp) 54 REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d 55 END TYPE PTR_4D_dp 35 INTERFACE mpp_nfd ! called by lbc_lnk_pt2pt or lbc_lnk_neicoll 36 MODULE PROCEDURE mpp_nfd_sp, mpp_nfd_dp 37 END INTERFACE 56 38 57 TYPE, PUBLIC :: PTR_2D_sp !: array of 2D pointers (also used in lib_mpp) 58 REAL(sp), DIMENSION (:,:) , POINTER :: pt2d 59 END TYPE PTR_2D_sp 60 TYPE, PUBLIC :: PTR_3D_sp !: array of 3D pointers (also used in lib_mpp) 61 REAL(sp), DIMENSION (:,:,:) , POINTER :: pt3d 62 END TYPE PTR_3D_sp 63 TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (also used in lib_mpp) 64 REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d 65 END TYPE PTR_4D_sp 66 67 39 INTERFACE lbc_nfd_nogather ! called by mpp_nfd 40 MODULE PROCEDURE lbc_nfd_nogather_sp, lbc_nfd_nogather_dp 41 END INTERFACE 42 43 PUBLIC mpp_nfd ! mpi north fold conditions 68 44 PUBLIC lbc_nfd ! north fold conditions 69 45 PUBLIC lbc_nfd_nogather ! north fold conditions (no allgather case) … … 82 58 83 59 !!---------------------------------------------------------------------- 84 !! *** routine lbc_nfd_(2,3,4)d *** 60 !! *** routine lbc_nfd_[sd]p *** 61 !! *** routine lbc_nfd_nogather_[sd]p *** 62 !! *** routine lbc_nfd_ext_[sd]p *** 85 63 !!---------------------------------------------------------------------- 86 64 !! … … 95 73 ! !== SINGLE PRECISION VERSIONS 96 74 ! 97 ! 98 ! !== 2D array and array of 2D pointer ==! 99 ! 100 # define SINGLE_PRECISION 101 # define DIM_2d 102 # define ROUTINE_NFD lbc_nfd_2d_sp 103 # include "lbc_nfd_generic.h90" 104 # undef ROUTINE_NFD 105 # define MULTI 106 # define ROUTINE_NFD lbc_nfd_2d_ptr_sp 107 # include "lbc_nfd_generic.h90" 108 # undef ROUTINE_NFD 109 # undef MULTI 110 # undef DIM_2d 111 ! 112 ! !== 2D array with extra haloes ==! 113 ! 114 # define DIM_2d 115 # define ROUTINE_NFD lbc_nfd_2d_ext_sp 116 # include "lbc_nfd_ext_generic.h90" 117 # undef ROUTINE_NFD 118 # undef DIM_2d 119 ! 120 ! !== 3D array and array of 3D pointer ==! 121 ! 122 # define DIM_3d 123 # define ROUTINE_NFD lbc_nfd_3d_sp 124 # include "lbc_nfd_generic.h90" 125 # undef ROUTINE_NFD 126 # define MULTI 127 # define ROUTINE_NFD lbc_nfd_3d_ptr_sp 128 # include "lbc_nfd_generic.h90" 129 # undef ROUTINE_NFD 130 # undef MULTI 131 # undef DIM_3d 132 ! 133 ! !== 4D array and array of 4D pointer ==! 134 ! 135 # define DIM_4d 136 # define ROUTINE_NFD lbc_nfd_4d_sp 137 # include "lbc_nfd_generic.h90" 138 # undef ROUTINE_NFD 139 # define MULTI 140 # define ROUTINE_NFD lbc_nfd_4d_ptr_sp 141 # include "lbc_nfd_generic.h90" 142 # undef ROUTINE_NFD 143 # undef MULTI 144 # undef DIM_4d 145 ! 146 ! lbc_nfd_nogather routines 147 ! 148 ! !== 2D array and array of 2D pointer ==! 149 ! 150 # define DIM_2d 151 # define ROUTINE_NFD lbc_nfd_nogather_2d_sp 152 # include "lbc_nfd_nogather_generic.h90" 153 # undef ROUTINE_NFD 154 # define MULTI 155 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_sp 156 # include "lbc_nfd_nogather_generic.h90" 157 # undef ROUTINE_NFD 158 # undef MULTI 159 # undef DIM_2d 160 ! 161 ! !== 3D array and array of 3D pointer ==! 162 ! 163 # define DIM_3d 164 # define ROUTINE_NFD lbc_nfd_nogather_3d_sp 165 # include "lbc_nfd_nogather_generic.h90" 166 # undef ROUTINE_NFD 167 # define MULTI 168 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_sp 169 # include "lbc_nfd_nogather_generic.h90" 170 # undef ROUTINE_NFD 171 # undef MULTI 172 # undef DIM_3d 173 ! 174 ! !== 4D array and array of 4D pointer ==! 175 ! 176 # define DIM_4d 177 # define ROUTINE_NFD lbc_nfd_nogather_4d_sp 178 # include "lbc_nfd_nogather_generic.h90" 179 # undef ROUTINE_NFD 180 !# define MULTI 181 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr 182 !# include "lbc_nfd_nogather_generic.h90" 183 !# undef ROUTINE_NFD 184 !# undef MULTI 185 # undef DIM_4d 186 # undef SINGLE_PRECISION 187 188 !!---------------------------------------------------------------------- 75 #define PRECISION sp 76 # include "lbc_nfd_generic.h90" 77 # include "lbc_nfd_nogather_generic.h90" 78 # include "lbc_nfd_ext_generic.h90" 79 #undef PRECISION 189 80 ! 190 81 ! !== DOUBLE PRECISION VERSIONS 191 82 ! 83 #define PRECISION dp 84 # include "lbc_nfd_generic.h90" 85 # include "lbc_nfd_nogather_generic.h90" 86 # include "lbc_nfd_ext_generic.h90" 87 #undef PRECISION 88 89 !!====================================================================== 192 90 ! 193 ! !== 2D array and array of 2D pointer ==!194 !195 # define DIM_2d196 # define ROUTINE_NFD lbc_nfd_2d_dp197 # include "lbc_nfd_generic.h90"198 # undef ROUTINE_NFD199 # define MULTI200 # define ROUTINE_NFD lbc_nfd_2d_ptr_dp201 # include "lbc_nfd_generic.h90"202 # undef ROUTINE_NFD203 # undef MULTI204 # undef DIM_2d205 !206 ! !== 2D array with extra haloes ==!207 !208 # define DIM_2d209 # define ROUTINE_NFD lbc_nfd_2d_ext_dp210 # include "lbc_nfd_ext_generic.h90"211 # undef ROUTINE_NFD212 # undef DIM_2d213 !214 ! !== 3D array and array of 3D pointer ==!215 !216 # define DIM_3d217 # define ROUTINE_NFD lbc_nfd_3d_dp218 # include "lbc_nfd_generic.h90"219 # undef ROUTINE_NFD220 # define MULTI221 # define ROUTINE_NFD lbc_nfd_3d_ptr_dp222 # include "lbc_nfd_generic.h90"223 # undef ROUTINE_NFD224 # undef MULTI225 # undef DIM_3d226 !227 ! !== 4D array and array of 4D pointer ==!228 !229 # define DIM_4d230 # define ROUTINE_NFD lbc_nfd_4d_dp231 # include "lbc_nfd_generic.h90"232 # undef ROUTINE_NFD233 # define MULTI234 # define ROUTINE_NFD lbc_nfd_4d_ptr_dp235 # include "lbc_nfd_generic.h90"236 # undef ROUTINE_NFD237 # undef MULTI238 # undef DIM_4d239 !240 ! lbc_nfd_nogather routines241 !242 ! !== 2D array and array of 2D pointer ==!243 !244 # define DIM_2d245 # define ROUTINE_NFD lbc_nfd_nogather_2d_dp246 # include "lbc_nfd_nogather_generic.h90"247 # undef ROUTINE_NFD248 # define MULTI249 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_dp250 # include "lbc_nfd_nogather_generic.h90"251 # undef ROUTINE_NFD252 # undef MULTI253 # undef DIM_2d254 !255 ! !== 3D array and array of 3D pointer ==!256 !257 # define DIM_3d258 # define ROUTINE_NFD lbc_nfd_nogather_3d_dp259 # include "lbc_nfd_nogather_generic.h90"260 # undef ROUTINE_NFD261 # define MULTI262 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_dp263 # include "lbc_nfd_nogather_generic.h90"264 # undef ROUTINE_NFD265 # undef MULTI266 # undef DIM_3d267 !268 ! !== 4D array and array of 4D pointer ==!269 !270 # define DIM_4d271 # define ROUTINE_NFD lbc_nfd_nogather_4d_dp272 # include "lbc_nfd_nogather_generic.h90"273 # undef ROUTINE_NFD274 !# define MULTI275 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr276 !# include "lbc_nfd_nogather_generic.h90"277 !# undef ROUTINE_NFD278 !# undef MULTI279 # undef DIM_4d280 281 91 !!---------------------------------------------------------------------- 282 283 92 !! *** routine mpp_nfd_[sd]p *** 93 !! 94 !! * Argument : dummy argument use in mpp_nfd_... routines 95 !! ptab : pointer of arrays on which the boundary condition is applied 96 !! cd_nat : nature of array grid-points 97 !! psgn : sign used across the north fold boundary 98 !! kfld : optional, number of pt3d arrays 99 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 100 !! pfillval : optional, background value (used with jpfillcopy) 101 !!---------------------------------------------------------------------- 102 !! 103 !! ---- SINGLE PRECISION VERSIONS 104 !! 105 #define PRECISION sp 106 # define MPI_TYPE MPI_REAL 107 # include "mpp_nfd_generic.h90" 108 # undef MPI_TYPE 109 #undef PRECISION 110 !! 111 !! ---- DOUBLE PRECISION VERSIONS 112 !! 113 #define PRECISION dp 114 # define MPI_TYPE MPI_DOUBLE_PRECISION 115 # include "mpp_nfd_generic.h90" 116 # undef MPI_TYPE 117 #undef PRECISION 284 118 285 119 !!====================================================================== -
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lib_mpp.F90
r14229 r14574 55 55 USE dom_oce ! ocean space and time domain 56 56 USE in_out_manager ! I/O manager 57 #if ! defined key_mpi_off 58 USE MPI 59 #endif 57 60 58 61 IMPLICIT NONE … … 107 110 END INTERFACE 108 111 112 TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (used in lbclnk and lbcnfd) 113 REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d 114 END TYPE PTR_4D_sp 115 116 TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (used in lbclnk and lbcnfd) 117 REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d 118 END TYPE PTR_4D_dp 119 109 120 !! ========================= !! 110 121 !! MPI variable definition !! 111 122 !! ========================= !! 112 123 #if ! defined key_mpi_off 113 !$AGRIF_DO_NOT_TREAT114 INCLUDE 'mpif.h'115 !$AGRIF_END_DO_NOT_TREAT116 124 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 117 125 #else … … 122 130 #endif 123 131 124 INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2)125 126 132 INTEGER, PUBLIC :: mppsize ! number of process 127 133 INTEGER, PUBLIC :: mpprank ! process number [ 0 - size-1 ] … … 132 138 INTEGER :: MPI_SUMDD 133 139 140 ! Neighbourgs informations 141 INTEGER, PARAMETER, PUBLIC :: n_hlsmax = 3 142 INTEGER, DIMENSION( 8), PUBLIC :: mpinei !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg) 143 INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiSnei !: 8-neighbourg Send MPI indexes (starting at 0, -1 if no neighbourg) 144 INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiRnei !: 8-neighbourg Recv MPI indexes (starting at 0, -1 if no neighbourg) 145 INTEGER, PARAMETER, PUBLIC :: jpwe = 1 !: WEst 146 INTEGER, PARAMETER, PUBLIC :: jpea = 2 !: EAst 147 INTEGER, PARAMETER, PUBLIC :: jpso = 3 !: SOuth 148 INTEGER, PARAMETER, PUBLIC :: jpno = 4 !: NOrth 149 INTEGER, PARAMETER, PUBLIC :: jpsw = 5 !: South-West 150 INTEGER, PARAMETER, PUBLIC :: jpse = 6 !: South-East 151 INTEGER, PARAMETER, PUBLIC :: jpnw = 7 !: North-West 152 INTEGER, PARAMETER, PUBLIC :: jpne = 8 !: North-East 153 154 LOGICAL, DIMENSION(8), PUBLIC :: l_SelfPerio ! should we explicitely take care of I/J periodicity 155 LOGICAL, PUBLIC :: l_IdoNFold 156 134 157 ! variables used for zonal integration 135 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average136 LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row137 INTEGER :: ngrp_znl !group ID for the znl processors138 INTEGER :: ndim_rank_znl !number of processors on the same zonal average158 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average 159 LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row 160 INTEGER :: ngrp_znl !: group ID for the znl processors 161 INTEGER :: ndim_rank_znl !: number of processors on the same zonal average 139 162 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 140 163 141 164 ! variables used for MPI3 neighbourhood collectives 142 INTEGER, PUBLIC :: mpi_nc_com! MPI3 neighbourhood collectives communicator143 INTEGER, PUBLIC :: mpi_nc_all_com! MPI3 neighbourhood collectives communicator (with diagionals)165 INTEGER, DIMENSION(n_hlsmax), PUBLIC :: mpi_nc_com4 ! MPI3 neighbourhood collectives communicator 166 INTEGER, DIMENSION(n_hlsmax), PUBLIC :: mpi_nc_com8 ! MPI3 neighbourhood collectives communicator (with diagionals) 144 167 145 168 ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) … … 187 210 188 211 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 189 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 212 INTEGER, PUBLIC :: nn_comm !: namelist control of comms 213 214 INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 215 INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 216 INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 217 INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 218 INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 190 219 191 220 !! * Substitutions … … 265 294 INTEGER , INTENT(in ) :: kdest ! receive process number 266 295 INTEGER , INTENT(in ) :: ktyp ! tag of the message 267 INTEGER , INTENT(in 296 INTEGER , INTENT(inout) :: md_req ! argument for isend 268 297 !! 269 298 INTEGER :: iflag … … 294 323 INTEGER , INTENT(in ) :: kdest ! receive process number 295 324 INTEGER , INTENT(in ) :: ktyp ! tag of the message 296 INTEGER , INTENT(in 325 INTEGER , INTENT(inout) :: md_req ! argument for isend 297 326 !! 298 327 INTEGER :: iflag … … 317 346 INTEGER , INTENT(in ) :: kdest ! receive process number 318 347 INTEGER , INTENT(in ) :: ktyp ! tag of the message 319 INTEGER , INTENT(in 348 INTEGER , INTENT(inout) :: md_req ! argument for isend 320 349 !! 321 350 INTEGER :: iflag … … 944 973 LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number 945 974 LOGICAL :: ll_abort 946 INTEGER :: info 975 INTEGER :: info, ierr 947 976 !!---------------------------------------------------------------------- 948 977 ll_abort = .FALSE. … … 951 980 #if ! defined key_mpi_off 952 981 IF(ll_abort) THEN 953 CALL mpi_abort( MPI_COMM_WORLD )982 CALL mpi_abort( MPI_COMM_WORLD, 123, info ) 954 983 ELSE 955 984 CALL mppsync … … 964 993 SUBROUTINE mpp_comm_free( kcom ) 965 994 !!---------------------------------------------------------------------- 966 INTEGER, INTENT(in ) :: kcom995 INTEGER, INTENT(inout) :: kcom 967 996 !! 968 997 INTEGER :: ierr … … 1002 1031 !!---------------------------------------------------------------------- 1003 1032 #if ! defined key_mpi_off 1004 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world1005 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world1006 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_oce : ', mpi_comm_oce1033 !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_world : ', ngrp_world 1034 !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - mpi_comm_world : ', mpi_comm_world 1035 !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - mpi_comm_oce : ', mpi_comm_oce 1007 1036 ! 1008 1037 ALLOCATE( kwork(jpnij), STAT=ierr ) … … 1015 1044 ! 1016 1045 CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr ) 1017 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork1046 !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - kwork pour njmpp : ', kwork 1018 1047 !-$$ CALL flush(numout) 1019 1048 ! … … 1025 1054 ENDIF 1026 1055 END DO 1027 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl1056 !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ndim_rank_znl : ', ndim_rank_znl 1028 1057 !-$$ CALL flush(numout) 1029 1058 ! Allocate the right size to nrank_znl … … 1038 1067 ENDIF 1039 1068 END DO 1040 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl1069 !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - nrank_znl : ', nrank_znl 1041 1070 !-$$ CALL flush(numout) 1042 1071 1043 1072 ! Create the opa group 1044 1073 CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr) 1045 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa1074 !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_opa : ', ngrp_opa 1046 1075 !-$$ CALL flush(numout) 1047 1076 1048 1077 ! Create the znl group from the opa group 1049 1078 CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr ) 1050 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl1079 !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_znl ', ngrp_znl 1051 1080 !-$$ CALL flush(numout) 1052 1081 1053 1082 ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row 1054 1083 CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr ) 1055 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl1084 !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ncomm_znl ', ncomm_znl 1056 1085 !-$$ CALL flush(numout) 1057 1086 ! … … 1073 1102 END SUBROUTINE mpp_ini_znl 1074 1103 1075 SUBROUTINE mpp_ini_nc 1104 1105 SUBROUTINE mpp_ini_nc( khls ) 1076 1106 !!---------------------------------------------------------------------- 1077 1107 !! *** routine mpp_ini_nc *** … … 1084 1114 ! 1085 1115 !! ** output 1086 !! mpi_nc_com = MPI3 neighbourhood collectives communicator 1087 !! mpi_nc_all_com = MPI3 neighbourhood collectives communicator 1088 !! (with diagonals) 1089 !! 1090 !!---------------------------------------------------------------------- 1091 INTEGER, DIMENSION(:), ALLOCATABLE :: ineigh, ineighalls, ineighallr 1092 INTEGER :: ideg, idegalls, idegallr, icont, icont1 1093 INTEGER :: ierr 1094 LOGICAL, PARAMETER :: ireord = .FALSE. 1095 1096 #if ! defined key_mpi_off 1097 1098 ideg = 0 1099 idegalls = 0 1100 idegallr = 0 1101 icont = 0 1102 icont1 = 0 1103 1104 IF (nbondi .eq. 1) THEN 1105 ideg = ideg + 1 1106 ELSEIF (nbondi .eq. -1) THEN 1107 ideg = ideg + 1 1108 ELSEIF (nbondi .eq. 0) THEN 1109 ideg = ideg + 2 1110 ENDIF 1111 1112 IF (nbondj .eq. 1) THEN 1113 ideg = ideg + 1 1114 ELSEIF (nbondj .eq. -1) THEN 1115 ideg = ideg + 1 1116 ELSEIF (nbondj .eq. 0) THEN 1117 ideg = ideg + 2 1118 ENDIF 1119 1120 idegalls = ideg 1121 idegallr = ideg 1122 1123 IF (nones .ne. -1) idegalls = idegalls + 1 1124 IF (nonws .ne. -1) idegalls = idegalls + 1 1125 IF (noses .ne. -1) idegalls = idegalls + 1 1126 IF (nosws .ne. -1) idegalls = idegalls + 1 1127 IF (noner .ne. -1) idegallr = idegallr + 1 1128 IF (nonwr .ne. -1) idegallr = idegallr + 1 1129 IF (noser .ne. -1) idegallr = idegallr + 1 1130 IF (noswr .ne. -1) idegallr = idegallr + 1 1131 1132 ALLOCATE(ineigh(ideg)) 1133 ALLOCATE(ineighalls(idegalls)) 1134 ALLOCATE(ineighallr(idegallr)) 1135 1136 IF (nbondi .eq. 1) THEN 1137 icont = icont + 1 1138 ineigh(icont) = nowe 1139 ineighalls(icont) = nowe 1140 ineighallr(icont) = nowe 1141 ELSEIF (nbondi .eq. -1) THEN 1142 icont = icont + 1 1143 ineigh(icont) = noea 1144 ineighalls(icont) = noea 1145 ineighallr(icont) = noea 1146 ELSEIF (nbondi .eq. 0) THEN 1147 icont = icont + 1 1148 ineigh(icont) = nowe 1149 ineighalls(icont) = nowe 1150 ineighallr(icont) = nowe 1151 icont = icont + 1 1152 ineigh(icont) = noea 1153 ineighalls(icont) = noea 1154 ineighallr(icont) = noea 1155 ENDIF 1156 1157 IF (nbondj .eq. 1) THEN 1158 icont = icont + 1 1159 ineigh(icont) = noso 1160 ineighalls(icont) = noso 1161 ineighallr(icont) = noso 1162 ELSEIF (nbondj .eq. -1) THEN 1163 icont = icont + 1 1164 ineigh(icont) = nono 1165 ineighalls(icont) = nono 1166 ineighallr(icont) = nono 1167 ELSEIF (nbondj .eq. 0) THEN 1168 icont = icont + 1 1169 ineigh(icont) = noso 1170 ineighalls(icont) = noso 1171 ineighallr(icont) = noso 1172 icont = icont + 1 1173 ineigh(icont) = nono 1174 ineighalls(icont) = nono 1175 ineighallr(icont) = nono 1176 ENDIF 1177 1178 icont1 = icont 1179 IF (nosws .ne. -1) THEN 1180 icont = icont + 1 1181 ineighalls(icont) = nosws 1182 ENDIF 1183 IF (noses .ne. -1) THEN 1184 icont = icont + 1 1185 ineighalls(icont) = noses 1186 ENDIF 1187 IF (nonws .ne. -1) THEN 1188 icont = icont + 1 1189 ineighalls(icont) = nonws 1190 ENDIF 1191 IF (nones .ne. -1) THEN 1192 icont = icont + 1 1193 ineighalls(icont) = nones 1194 ENDIF 1195 IF (noswr .ne. -1) THEN 1196 icont1 = icont1 + 1 1197 ineighallr(icont1) = noswr 1198 ENDIF 1199 IF (noser .ne. -1) THEN 1200 icont1 = icont1 + 1 1201 ineighallr(icont1) = noser 1202 ENDIF 1203 IF (nonwr .ne. -1) THEN 1204 icont1 = icont1 + 1 1205 ineighallr(icont1) = nonwr 1206 ENDIF 1207 IF (noner .ne. -1) THEN 1208 icont1 = icont1 + 1 1209 ineighallr(icont1) = noner 1210 ENDIF 1211 1212 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, ideg, ineigh, MPI_UNWEIGHTED, ideg, ineigh, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_com, ierr) 1213 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, idegallr, ineighallr, MPI_UNWEIGHTED, idegalls, ineighalls, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_all_com, ierr) 1214 1215 DEALLOCATE (ineigh) 1216 DEALLOCATE (ineighalls) 1217 DEALLOCATE (ineighallr) 1116 !! mpi_nc_com4 = MPI3 neighbourhood collectives communicator 1117 !! mpi_nc_com8 = MPI3 neighbourhood collectives communicator (with diagonals) 1118 !!---------------------------------------------------------------------- 1119 INTEGER, INTENT(in ) :: khls ! halo size, default = nn_hls 1120 ! 1121 INTEGER, DIMENSION(:), ALLOCATABLE :: iSnei4, iRnei4, iSnei8, iRnei8 1122 INTEGER :: iScnt4, iRcnt4, iScnt8, iRcnt8 1123 INTEGER :: ierr 1124 LOGICAL, PARAMETER :: ireord = .FALSE. 1125 !!---------------------------------------------------------------------- 1126 #if ! defined key_mpi_off && ! defined key_mpi2 1127 1128 iScnt4 = COUNT( mpiSnei(khls,1:4) >= 0 ) 1129 iRcnt4 = COUNT( mpiRnei(khls,1:4) >= 0 ) 1130 iScnt8 = COUNT( mpiSnei(khls,1:8) >= 0 ) 1131 iRcnt8 = COUNT( mpiRnei(khls,1:8) >= 0 ) 1132 1133 ALLOCATE( iSnei4(iScnt4), iRnei4(iRcnt4), iSnei8(iScnt8), iRnei8(iRcnt8) ) ! ok if icnt4 or icnt8 = 0 1134 1135 iSnei4 = PACK( mpiSnei(khls,1:4), mask = mpiSnei(khls,1:4) >= 0 ) 1136 iRnei4 = PACK( mpiRnei(khls,1:4), mask = mpiRnei(khls,1:4) >= 0 ) 1137 iSnei8 = PACK( mpiSnei(khls,1:8), mask = mpiSnei(khls,1:8) >= 0 ) 1138 iRnei8 = PACK( mpiRnei(khls,1:8), mask = mpiRnei(khls,1:8) >= 0 ) 1139 1140 CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt4, iSnei4, MPI_UNWEIGHTED, iRcnt4, iRnei4, MPI_UNWEIGHTED, & 1141 & MPI_INFO_NULL, ireord, mpi_nc_com4(khls), ierr ) 1142 CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt8, iSnei8, MPI_UNWEIGHTED, iRcnt8, iRnei8, MPI_UNWEIGHTED, & 1143 & MPI_INFO_NULL, ireord, mpi_nc_com8(khls), ierr) 1144 1145 DEALLOCATE( iSnei4, iRnei4, iSnei8, iRnei8 ) 1218 1146 #endif 1219 1147 END SUBROUTINE mpp_ini_nc 1220 1221 1148 1222 1149 … … 1234 1161 !! 1235 1162 !! ** output 1236 !! njmppmax = njmpp for northern procs1237 1163 !! ndim_rank_north = number of processors in the northern line 1238 1164 !! nrank_north (ndim_rank_north) = number of the northern procs. … … 1249 1175 ! 1250 1176 #if ! defined key_mpi_off 1251 njmppmax = MAXVAL( njmppt )1252 1177 ! 1253 1178 ! Look for how many procs on the northern boundary … … 1400 1325 END DO 1401 1326 IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN 1402 WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(n com_rec_max))1327 WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 1403 1328 END IF 1404 1329 WRITE(numcom,*) ' ' -
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
r14229 r14574 31 31 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 32 32 ! ! = T , U , V , F or W -points 33 REAL( wp), INTENT(in ) :: psgn ! = -1. the sign change across the33 REAL(PRECISION) , INTENT(in ) :: psgn ! = -1. the sign change across the 34 34 !! ! north fold, = 1. otherwise 35 35 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold -
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/mpp_lnk_icb_generic.h90
r13286 r14574 24 24 !! jpi : first dimension of the local subdomain 25 25 !! jpj : second dimension of the local subdomain 26 !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 26 27 !! kexti : number of columns for extra outer halo 27 28 !! kextj : number of rows for extra outer halo 28 !! nbondi : mark for "east-west local boundary"29 !! nbondj : mark for "north-south local boundary"30 !! noea : number for local neighboring processors31 !! nowe : number for local neighboring processors32 !! noso : number for local neighboring processors33 !! nono : number for local neighboring processors34 29 !!---------------------------------------------------------------------- 35 30 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 36 31 REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 37 32 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 38 REAL( wp), INTENT(in ) :: psgn ! sign used across the north fold33 REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold 39 34 INTEGER , INTENT(in ) :: kexti ! extra i-halo width 40 35 INTEGER , INTENT(in ) :: kextj ! extra j-halo width … … 90 85 ! north fold treatment 91 86 ! ----------------------- 92 IF( npolj /= 0) THEN87 IF( l_IdoNFold ) THEN 93 88 ! 94 89 SELECT CASE ( jpni ) … … 103 98 ! we play with the neigbours AND the row number because of the periodicity 104 99 ! 105 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 106 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 100 IF( mpinei(jpwe) >= 0 .OR. mpinei(jpea) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) 107 101 iihom = jpi - (2 * nn_hls) -kexti 108 102 DO jl = 1, ipreci … … 110 104 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 111 105 END DO 112 END SELECT106 ENDIF 113 107 ! 114 108 ! ! Migrations … … 120 114 IF( ln_timing ) CALL tic_tac(.TRUE.) 121 115 ! 122 SELECT CASE ( nbondi ) 123 CASE ( -1 ) 124 CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 125 CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea ) 126 CALL mpi_wait(ml_req1,ml_stat,ml_err) 127 CASE ( 0 ) 128 CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 129 CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 130 CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea ) 131 CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 132 CALL mpi_wait(ml_req1,ml_stat,ml_err) 133 CALL mpi_wait(ml_req2,ml_stat,ml_err) 134 CASE ( 1 ) 135 CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 136 CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 137 CALL mpi_wait(ml_req1,ml_stat,ml_err) 138 END SELECT 116 IF( mpinei(jpwe) >= 0 ) CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, mpinei(jpwe), ml_req1 ) 117 IF( mpinei(jpea) >= 0 ) CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, mpinei(jpea), ml_req2 ) 118 IF( mpinei(jpwe) >= 0 ) CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, mpinei(jpwe) ) 119 IF( mpinei(jpea) >= 0 ) CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, mpinei(jpea) ) 120 IF( mpinei(jpwe) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) 121 IF( mpinei(jpea) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) 139 122 ! 140 123 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 142 125 ! ! Write Dirichlet lateral conditions 143 126 iihom = jpi - nn_hls 144 ! 145 SELECT CASE ( nbondi ) 146 CASE ( -1 ) 127 IF( mpinei(jpwe) >= 0 ) THEN 128 DO jl = 1, ipreci 129 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 130 END DO 131 ENDIF 132 IF( mpinei(jpea) >= 0 ) THEN 147 133 DO jl = 1, ipreci 148 134 pt2d(iihom+jl,:) = r2dew(:,jl,2) 149 135 END DO 150 CASE ( 0 ) 151 DO jl = 1, ipreci 152 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 153 pt2d(iihom+jl,:) = r2dew(:,jl,2) 154 END DO 155 CASE ( 1 ) 156 DO jl = 1, ipreci 157 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 158 END DO 159 END SELECT 160 136 ENDIF 161 137 162 138 ! 3. North and south directions … … 164 140 ! always closed : we play only with the neigbours 165 141 ! 166 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions142 IF( mpinei(jpso) >= 0 .OR. mpinei(jpno) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) 167 143 ijhom = jpj - (2 * nn_hls) - kextj 168 144 DO jl = 1, iprecj … … 177 153 IF( ln_timing ) CALL tic_tac(.TRUE.) 178 154 ! 179 SELECT CASE ( nbondj ) 180 CASE ( -1 ) 181 CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 182 CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono ) 183 CALL mpi_wait(ml_req1,ml_stat,ml_err) 184 CASE ( 0 ) 185 CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 186 CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 187 CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono ) 188 CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso ) 189 CALL mpi_wait(ml_req1,ml_stat,ml_err) 190 CALL mpi_wait(ml_req2,ml_stat,ml_err) 191 CASE ( 1 ) 192 CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 193 CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso ) 194 CALL mpi_wait(ml_req1,ml_stat,ml_err) 195 END SELECT 155 IF( mpinei(jpso) >= 0 ) CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, mpinei(jpso), ml_req1 ) 156 IF( mpinei(jpno) >= 0 ) CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, mpinei(jpno), ml_req2 ) 157 IF( mpinei(jpso) >= 0 ) CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, mpinei(jpso) ) 158 IF( mpinei(jpno) >= 0 ) CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, mpinei(jpno) ) 159 IF( mpinei(jpso) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) 160 IF( mpinei(jpno) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) 196 161 ! 197 162 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 200 165 ijhom = jpj - nn_hls 201 166 ! 202 SELECT CASE ( nbondj ) 203 CASE ( -1 ) 204 DO jl = 1, iprecj 205 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 206 END DO 207 CASE ( 0 ) 208 DO jl = 1, iprecj 209 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 210 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 211 END DO 212 CASE ( 1 ) 167 IF( mpinei(jpso) >= 0 ) THEN 213 168 DO jl = 1, iprecj 214 169 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 215 170 END DO 216 END SELECT 171 ENDIF 172 IF( mpinei(jpno) >= 0 ) THEN 173 DO jl = 1, iprecj 174 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 175 END DO 176 ENDIF 217 177 ! 218 178 END SUBROUTINE ROUTINE_LNK -
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/mpp_nfd_generic.h90
r14229 r14574 1 #if defined MULTI2 # define NAT_IN(k) cd_nat(k)3 # define SGN_IN(k) psgn(k)4 # define F_SIZE(ptab) kfld5 # define LBC_ARG (jf)6 # if defined DIM_2d7 # if defined SINGLE_PRECISION8 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f)9 # else10 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f)11 # endif12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)13 # define K_SIZE(ptab) 114 # define L_SIZE(ptab) 115 # endif16 # if defined DIM_3d17 # if defined SINGLE_PRECISION18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f)19 # else20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f)21 # endif22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)24 # define L_SIZE(ptab) 125 # endif26 # if defined DIM_4d27 # if defined SINGLE_PRECISION28 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f)29 # else30 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f)31 # endif32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)34 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)35 # endif36 #else37 ! !== IN: ptab is an array ==!38 # if defined SINGLE_PRECISION39 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)40 # else41 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)42 # endif43 # define NAT_IN(k) cd_nat44 # define SGN_IN(k) psgn45 # define F_SIZE(ptab) 146 # define LBC_ARG47 # if defined DIM_2d48 # define ARRAY_IN(i,j,k,l,f) ptab(i,j)49 # define K_SIZE(ptab) 150 # define L_SIZE(ptab) 151 # endif52 # if defined DIM_3d53 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k)54 # define K_SIZE(ptab) SIZE(ptab,3)55 # define L_SIZE(ptab) 156 # endif57 # if defined DIM_4d58 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l)59 # define K_SIZE(ptab) SIZE(ptab,3)60 # define L_SIZE(ptab) SIZE(ptab,4)61 # endif62 #endif63 1 64 # if defined SINGLE_PRECISION 65 # define PRECISION sp 66 # define SENDROUTINE mppsend_sp 67 # define RECVROUTINE mpprecv_sp 68 # define MPI_TYPE MPI_REAL 69 # define HUGEVAL(x) HUGE(x/**/_sp) 70 # else 71 # define PRECISION dp 72 # define SENDROUTINE mppsend_dp 73 # define RECVROUTINE mpprecv_dp 74 # define MPI_TYPE MPI_DOUBLE_PRECISION 75 # define HUGEVAL(x) HUGE(x/**/_dp) 76 # endif 77 78 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 79 !!---------------------------------------------------------------------- 80 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 83 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 84 REAL(wp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 2 SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld ) 3 TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 4 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 5 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary 6 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 7 REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 8 INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls 9 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 86 10 ! 87 11 LOGICAL :: ll_add_line … … 95 19 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 96 20 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 97 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather98 21 ! ! Workspace for message transfers avoiding mpi_allgather 99 22 INTEGER :: ipj_b ! sum of lines for all multi fields … … 103 26 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 104 27 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 105 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: z tabglo, znorthloc28 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc 106 29 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo 30 TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c. 107 31 !!---------------------------------------------------------------------- 108 32 ! 109 ipk = K_SIZE(ptab) ! 3rd dimension110 ipl = L_SIZE(ptab) ! 4th -111 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)33 ipk = SIZE(ptab(1)%pt4d,3) 34 ipl = SIZE(ptab(1)%pt4d,4) 35 ipf = kfld 112 36 ! 113 IF( l _north_nogather ) THEN !== no allgather exchanges ==!37 IF( ln_nnogather ) THEN !== no allgather exchanges ==! 114 38 115 39 ! --- define number of exchanged lines --- … … 118 42 ! 119 43 ! However, some other points are duplicated in the north pole folding: 120 ! - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls)121 ! - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls)122 ! - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls)123 ! - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls)124 ! - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls)125 ! - jperio=[56], grid=U : no points are duplicated126 ! - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls)127 ! - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1)44 ! - c_NFtype='T', grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 45 ! - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 46 ! - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 47 ! - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 48 ! - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 49 ! - c_NFtype='F', grid=U : no points are duplicated 50 ! - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 51 ! - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 128 52 ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 129 53 ! This explain why these duplicated points may have different values even if they are at the exact same location. … … 141 65 IF( ll_add_line ) THEN 142 66 DO jf = 1, ipf ! Loop over the number of arrays to be processed 143 ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) )67 ipj_s(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) 144 68 END DO 145 69 ELSE 146 ipj_s(:) = nn_hls70 ipj_s(:) = khls 147 71 ENDIF 148 72 … … 155 79 DO jf = 1, ipf ! Loop over the number of arrays to be processed 156 80 ! 157 SELECT CASE ( npolj ) 158 CASE ( 3, 4 ) ! * North fold T-point pivot 159 SELECT CASE ( NAT_IN(jf) ) 81 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 82 SELECT CASE ( cd_nat(jf) ) 160 83 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 161 84 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point 162 85 END SELECT 163 CASE ( 5, 6 ) ! * North fold F-point pivot 164 SELECT CASE ( NAT_IN(jf) ) 86 ENDIF 87 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 88 SELECT CASE ( cd_nat(jf) ) 165 89 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 166 90 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point 167 91 END SELECT 168 END SELECT92 ENDIF 169 93 ! 170 94 DO jj = 1, ipj_s(jf) 171 95 ij1 = ij1 + 1 172 96 jj_b(jj,jf) = ij1 173 jj_s(jj,jf) = jpj - 2* nn_hls + jj - i01297 jj_s(jj,jf) = jpj - 2*khls + jj - i012 174 98 END DO 175 99 ! … … 184 108 ij2 = jj_s(jj,jf) 185 109 DO ji = 1, jpi 186 ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf)110 ztabb(ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 187 111 END DO 188 112 DO ji = jpi+1, jpimax 189 ztabb(ji,ij1,jk,jl) = HUGE VAL(0.) ! avoid sending uninitialized values (make sure we don't use it)113 ztabb(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it) 190 114 END DO 191 115 END DO … … 199 123 iproc = nfproc(isendto(jr)) 200 124 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 201 CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 125 #if ! defined key_mpi_off 126 CALL MPI_ISEND( ztabb, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ml_req_nf(jr), ierr ) 127 #endif 202 128 ENDIF 203 129 END DO … … 212 138 ipi = nfjpi (ipni) 213 139 ! 214 IF( ipni == 1 ) THEN ; iis0 = 1 215 ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain216 ENDIF 217 IF( ipni == jpni ) THEN ; iie0 = ipi 218 ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain140 IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column 141 ELSE ; iis0 = 1 + khls ! default: -> from inner domain 142 ENDIF 143 IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column 144 ELSE ; iie0 = ipi - khls ! default: -> until inner domain 219 145 ENDIF 220 146 impp = nfimpp(ipni) - nfimpp(isendto(1)) … … 230 156 ij2 = jj_s(jj,jf) 231 157 DO ji = iis0, iie0 232 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point158 ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st iner domain point 233 159 END DO 234 160 END DO … … 251 177 ij2 = jj_s(jj,jf) 252 178 DO ji = iis0, iie0 253 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf)179 ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 254 180 END DO 255 181 END DO … … 258 184 ELSE ! get data from a neighbour trough communication 259 185 ! 260 CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 186 #if ! defined key_mpi_off 187 CALL MPI_RECV( ztabw, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, MPI_STATUS_IGNORE, ierr ) 188 #endif 261 189 DO jl = 1, ipl ; DO jk = 1, ipk 262 190 DO jj = 1, ipj_b … … 278 206 ij1 = jj_b( 1 ,jf) 279 207 ij2 = jj_b(ipj_s(jf),jf) 280 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat LBC_ARG, psgn LBC_ARG)208 CALL lbc_nfd_nogather( ptab(jf)%pt4d(:,:,:,:), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf), khls ) 281 209 END DO 282 210 ! … … 286 214 iproc = nfproc(isendto(jr)) 287 215 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 288 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate216 CALL mpi_wait( ml_req_nf(jr), MPI_STATUS_IGNORE, ml_err ) ! put the wait at the very end just before the deallocate 289 217 ENDIF 290 218 END DO … … 294 222 ! 295 223 ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) 296 ipj = nn_hls + 2224 ipj = khls + 2 297 225 ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) 298 ipj2 = 2 * nn_hls + 2299 ! 300 i0max = jpimax - 2 * nn_hls226 ipj2 = 2 * khls + 2 227 ! 228 i0max = jpimax - 2 * khls 301 229 ibuffsize = i0max * ipj * ipk * ipl * ipf 302 230 ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) … … 307 235 DO ji = 1, Ni_0 308 236 ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 309 znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf)237 znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl) 310 238 END DO 311 239 DO ji = Ni_0+1, i0max 312 znorthloc(ji,jj,jk,jl,jf) = HUGE VAL(0.) ! avoid sending uninitialized values (make sure we don't use it)240 znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it) 313 241 END DO 314 242 END DO … … 323 251 IF( ln_timing ) CALL tic_tac(.FALSE.) 324 252 DEALLOCATE( znorthloc ) 325 ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) ) 326 ! 327 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines 253 ALLOCATE( ztabglo(ipf) ) 254 DO jf = 1, ipf 255 ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) ) 256 END DO 257 ! 258 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines 328 259 ijnr = 0 329 260 DO jr = 1, jpni ! recover the global north array 330 261 iproc = nfproc(jr) 331 262 impp = nfimpp(jr) 332 ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc263 ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc 333 264 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 334 265 ! … … 340 271 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 341 272 DO ji = 1, ipi 342 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc343 ztabglo( ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point273 ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc 274 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point 344 275 END DO 345 276 END DO … … 349 280 DO jj = 1, ipj 350 281 DO ji = 1, ipi 351 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc352 ztabglo( ii1,jj,jk,jl,jf) = pfillval282 ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc 283 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval 353 284 END DO 354 285 END DO … … 361 292 DO jj = 1, ipj 362 293 DO ji = 1, ipi 363 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc364 ztabglo( ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr)294 ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc 295 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr) 365 296 END DO 366 297 END DO … … 372 303 ! 373 304 DO jf = 1, ipf 374 CALL lbc_nfd( ztabglo( :,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG) ! North fold boundary condition305 CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition 375 306 DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity 376 DO jj = 1, nn_hls + 1377 ij1 = ipj2 - ( nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2378 ztabglo( 1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf)379 ztabglo(j piglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf)307 DO jj = 1, khls + 1 308 ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2 309 ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl) 310 ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl) 380 311 END DO 381 312 END DO ; END DO … … 383 314 ! 384 315 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN 385 DO jj = 1, nn_hls + 1386 ij1 = jpj - ( nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj387 ij2 = ipj2 - ( nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2316 DO jj = 1, khls + 1 317 ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj 318 ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2 388 319 DO ji= 1, jpi 389 320 ii2 = mig(ji) 390 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf)321 ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl) 391 322 END DO 392 323 END DO 393 324 END DO ; END DO ; END DO 394 325 ! 326 DO jf = 1, ipf 327 DEALLOCATE( ztabglo(jf)%pt4d ) 328 END DO 395 329 DEALLOCATE( ztabglo ) 396 330 ! 397 331 ENDIF ! l_north_nogather 398 332 ! 399 END SUBROUTINE ROUTINE_NFD333 END SUBROUTINE mpp_nfd_/**/PRECISION 400 334 401 #undef PRECISION402 #undef MPI_TYPE403 #undef SENDROUTINE404 #undef RECVROUTINE405 #undef ARRAY_TYPE406 #undef NAT_IN407 #undef SGN_IN408 #undef ARRAY_IN409 #undef K_SIZE410 #undef L_SIZE411 #undef F_SIZE412 #undef LBC_ARG413 #undef HUGEVAL -
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/mppini.F90
r14229 r14574 69 69 jpi = jpiglo 70 70 jpj = jpjglo 71 jpk = jpkglo 72 jpim1 = jpi-1 ! inner domain indices 73 jpjm1 = jpj-1 ! " " 74 jpkm1 = MAX( 1, jpk-1 ) ! " " 71 jpk = MAX( 2, jpkglo ) 75 72 jpij = jpi*jpj 76 73 jpni = 1 … … 79 76 nimpp = 1 80 77 njmpp = 1 81 nbondi = 282 nbondj = 283 78 nidom = FLIO_DOM_NONE 84 npolj = 085 IF( jperio == 3 .OR. jperio == 4 ) npolj = 386 IF( jperio == 5 .OR. jperio == 6 ) npolj = 587 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7)88 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7)89 79 ! 90 80 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) … … 95 85 WRITE(numout,*) '~~~~~~~~ ' 96 86 WRITE(numout,*) ' l_Iperio = ', l_Iperio, ' l_Jperio = ', l_Jperio 97 WRITE(numout,*) ' n polj = ', npolj , ' njmpp = ', njmpp87 WRITE(numout,*) ' njmpp = ', njmpp 98 88 ENDIF 99 89 ! … … 123 113 !! ** Method : Global domain is distributed in smaller local domains. 124 114 !! Periodic condition is a function of the local domain position 125 !! (global boundary or neighbouring domain) and of the global 126 !! periodic 127 !! Type : jperio global periodic condition 115 !! (global boundary or neighbouring domain) and of the global periodic 128 116 !! 129 117 !! ** Action : - set domain parameters … … 131 119 !! njmpp : latitudinal index 132 120 !! narea : number for local area 133 !! nbondi : mark for "east-west local boundary" 134 !! nbondj : mark for "north-south local boundary" 135 !! nproc : number for local processor 136 !! noea : number for local neighboring processor 137 !! nowe : number for local neighboring processor 138 !! noso : number for local neighboring processor 139 !! nono : number for local neighboring processor 140 !!---------------------------------------------------------------------- 141 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 142 INTEGER :: inijmin 143 INTEGER :: inum ! local logical unit 144 INTEGER :: idir, ifreq ! local integers 145 INTEGER :: ii, il1, ili, imil ! - - 146 INTEGER :: ij, il2, ilj, ijm1 ! - - 147 INTEGER :: iino, ijno, iiso, ijso ! - - 148 INTEGER :: iiea, ijea, iiwe, ijwe ! - - 149 INTEGER :: iarea0 ! - - 150 INTEGER :: ierr, ios ! 151 INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 121 !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 122 !!---------------------------------------------------------------------- 123 INTEGER :: ji, jj, jn, jp, jh 124 INTEGER :: ii, ij, ii2, ij2 125 INTEGER :: inijmin ! number of oce subdomains 126 INTEGER :: inum, inum0 127 INTEGER :: ifreq, il1, imil, il2, ijm1 128 INTEGER :: ierr, ios 129 INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 130 INTEGER, DIMENSION(16*n_hlsmax) :: ichanged 131 INTEGER, ALLOCATABLE, DIMENSION(: ) :: iin, ijn 132 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: iimppt, ijpi, ipproc 133 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: ijmppt, ijpj 134 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: impi 135 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: inei 152 136 LOGICAL :: llbest, llauto 153 137 LOGICAL :: llwrtlay 138 LOGICAL :: llmpi_Iperio, llmpi_Jperio, llmpiNFold 154 139 LOGICAL :: ln_listonly 155 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 156 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 157 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 158 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 159 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 160 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 161 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 140 LOGICAL, ALLOCATABLE, DIMENSION(:,: ) :: llisOce ! is not land-domain only? 141 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: llnei ! are neighbourgs existing? 162 142 NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & 163 143 & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & … … 166 146 & cn_ice, nn_ice_dta, & 167 147 & ln_vol, nn_volctl, nn_rimwidth 168 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 148 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly, nn_comm 169 149 !!---------------------------------------------------------------------- 170 150 ! … … 194 174 IF(lwm) WRITE( numond, nammpp ) 195 175 ! 196 !!!------------------------------------197 !!! nn_hls shloud be read in nammpp198 !!!------------------------------------199 176 jpiglo = Ni0glo + 2 * nn_hls 200 177 jpjglo = Nj0glo + 2 * nn_hls … … 214 191 ! ----------------------------------- 215 192 ! 216 ! If dimensions of processors grid weren't specified in the namelist file193 ! If dimensions of MPI processes grid weren't specified in the namelist file 217 194 ! then we calculate them here now that we have our communicator size 218 195 IF(lwp) THEN … … 261 238 262 239 ! look for land mpi subdomains... 263 ALLOCATE( llis oce(jpni,jpnj) )264 CALL mpp_is_ocean( llis oce )265 inijmin = COUNT( llis oce ) ! number of oce subdomains240 ALLOCATE( llisOce(jpni,jpnj) ) 241 CALL mpp_is_ocean( llisOce ) 242 inijmin = COUNT( llisOce ) ! number of oce subdomains 266 243 267 244 IF( mppsize < inijmin ) THEN ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... … … 320 297 9003 FORMAT (a, i5) 321 298 322 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 323 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 324 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 325 & nie0all(jpnij) , nje0all(jpnij) , & 326 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 327 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 328 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 329 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 330 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 331 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 332 & STAT=ierr ) 299 ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni), & 300 & iin(jpnij), ijn(jpnij), & 301 & iimppt(jpni,jpnj), ijmppt(jpni,jpnj), ijpi(jpni,jpnj), ijpj(jpni,jpnj), ipproc(jpni,jpnj), & 302 & inei(8,jpni,jpnj), llnei(8,jpni,jpnj), & 303 & impi(8,jpnij), & 304 & STAT=ierr ) 333 305 CALL mpp_sum( 'mppini', ierr ) 334 306 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' ) … … 344 316 ! 345 317 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 346 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 347 ! 348 !DO jn = 1, jpni 349 ! jproc = ipproc(jn,jpnj) 350 ! ii = iin(jproc+1) 351 ! ij = ijn(jproc+1) 352 ! nfproc(jn) = jproc 353 ! nfimpp(jn) = iimppt(ii,ij) 354 ! nfjpi (jn) = ijpi(ii,ij) 355 !END DO 356 nfproc(:) = ipproc(:,jpnj) 357 nfimpp(:) = iimppt(:,jpnj) 358 nfjpi (:) = ijpi(:,jpnj) 318 CALL mpp_getnum( llisOce, ipproc, iin, ijn ) 319 ! 320 ii = iin(narea) 321 ij = ijn(narea) 322 jpi = ijpi(ii,ij) 323 jpj = ijpj(ii,ij) 324 jpk = MAX( 2, jpkglo ) 325 jpij = jpi*jpj 326 nimpp = iimppt(ii,ij) 327 njmpp = ijmppt(ii,ij) 328 ! 329 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 359 330 ! 360 331 IF(lwp) THEN … … 366 337 WRITE(numout,*) ' jpnj = ', jpnj 367 338 WRITE(numout,*) ' jpnij = ', jpnij 339 WRITE(numout,*) ' nimpp = ', nimpp 340 WRITE(numout,*) ' njmpp = ', njmpp 368 341 WRITE(numout,*) 369 342 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 370 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 371 ENDIF 372 373 ! 3. Subdomain description in the Regular Case 374 ! -------------------------------------------- 375 ! specific cases where there is no communication -> must do the periodicity by itself 376 ! Warning: because of potential land-area suppression, do not use nbond[ij] == 2 377 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 378 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 379 380 DO jarea = 1, jpni*jpnj 381 ! 382 iarea0 = jarea - 1 383 ii = 1 + MOD(iarea0,jpni) 384 ij = 1 + iarea0/jpni 385 ili = ijpi(ii,ij) 386 ilj = ijpj(ii,ij) 387 ibondi(ii,ij) = 0 ! default: has e-w neighbours 388 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour 389 IF( ii == jpni ) ibondi(ii,ij) = 1 ! last column, has only w neighbour 390 IF( jpni == 1 ) ibondi(ii,ij) = 2 ! has no e-w neighbour 391 ibondj(ii,ij) = 0 ! default: has n-s neighbours 392 IF( ij == 1 ) ibondj(ii,ij) = -1 ! first row, has only n neighbour 393 IF( ij == jpnj ) ibondj(ii,ij) = 1 ! last row, has only s neighbour 394 IF( jpnj == 1 ) ibondj(ii,ij) = 2 ! has no n-s neighbour 395 396 ! Subdomain neighbors (get their zone number): default definition 397 ioso(ii,ij) = iarea0 - jpni 398 iowe(ii,ij) = iarea0 - 1 399 ioea(ii,ij) = iarea0 + 1 400 iono(ii,ij) = iarea0 + jpni 401 iis0(ii,ij) = 1 + nn_hls 402 iie0(ii,ij) = ili - nn_hls 403 ijs0(ii,ij) = 1 + nn_hls 404 ije0(ii,ij) = ilj - nn_hls 405 406 ! East-West periodicity: change ibondi, ioea, iowe 407 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 408 IF( jpni /= 1 ) ibondi(ii,ij) = 0 ! redefine: all have e-w neighbours 409 IF( ii == 1 ) iowe(ii,ij) = iarea0 + (jpni-1) ! redefine: first column, address of w neighbour 410 IF( ii == jpni ) ioea(ii,ij) = iarea0 - (jpni-1) ! redefine: last column, address of e neighbour 411 ENDIF 412 413 ! Simple North-South periodicity: change ibondj, ioso, iono 414 IF( jperio == 2 .OR. jperio == 7 ) THEN 415 IF( jpnj /= 1 ) ibondj(ii,ij) = 0 ! redefine: all have n-s neighbours 416 IF( ij == 1 ) ioso(ii,ij) = iarea0 + jpni * (jpnj-1) ! redefine: first row, address of s neighbour 417 IF( ij == jpnj ) iono(ii,ij) = iarea0 - jpni * (jpnj-1) ! redefine: last row, address of n neighbour 418 ENDIF 419 420 ! North fold: define ipolj, change iono. Warning: we do not change ibondj... 421 ipolj(ii,ij) = 0 422 IF( jperio == 3 .OR. jperio == 4 ) THEN 423 ijm1 = jpni*(jpnj-1) 424 imil = ijm1+(jpni+1)/2 425 IF( jarea > ijm1 ) ipolj(ii,ij) = 3 426 IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4 427 IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour 428 ENDIF 429 IF( jperio == 5 .OR. jperio == 6 ) THEN 430 ijm1 = jpni*(jpnj-1) 431 imil = ijm1+(jpni+1)/2 432 IF( jarea > ijm1) ipolj(ii,ij) = 5 433 IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6 434 IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour 435 ENDIF 436 ! 437 END DO 438 439 ! 4. deal with land subdomains 440 ! ---------------------------- 441 ! 442 ! neighbour treatment: change ibondi, ibondj if next to a land zone 443 DO jarea = 1, jpni*jpnj 444 ii = 1 + MOD( jarea-1 , jpni ) 445 ij = 1 + (jarea-1) / jpni 446 ! land-only area with an active n neigbour 447 IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN 448 iino = 1 + MOD( iono(ii,ij) , jpni ) ! ii index of this n neigbour 449 ijno = 1 + iono(ii,ij) / jpni ! ij index of this n neigbour 450 ! In case of north fold exchange: I am the n neigbour of my n neigbour!! (#1057) 451 ! --> for northern neighbours of northern row processors (in case of north-fold) 452 ! need to reverse the LOGICAL direction of communication 453 idir = 1 ! we are indeed the s neigbour of this n neigbour 454 IF( ij == jpnj .AND. ijno == jpnj ) idir = -1 ! both are on the last row, we are in fact the n neigbour 455 IF( ibondj(iino,ijno) == idir ) ibondj(iino,ijno) = 2 ! this n neigbour had only a s/n neigbour -> no more 456 IF( ibondj(iino,ijno) == 0 ) ibondj(iino,ijno) = -idir ! this n neigbour had both, n-s neighbours -> keep 1 457 ENDIF 458 ! land-only area with an active s neigbour 459 IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN 460 iiso = 1 + MOD( ioso(ii,ij) , jpni ) ! ii index of this s neigbour 461 ijso = 1 + ioso(ii,ij) / jpni ! ij index of this s neigbour 462 IF( ibondj(iiso,ijso) == -1 ) ibondj(iiso,ijso) = 2 ! this s neigbour had only a n neigbour -> no more neigbour 463 IF( ibondj(iiso,ijso) == 0 ) ibondj(iiso,ijso) = 1 ! this s neigbour had both, n-s neighbours -> keep s neigbour 464 ENDIF 465 ! land-only area with an active e neigbour 466 IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN 467 iiea = 1 + MOD( ioea(ii,ij) , jpni ) ! ii index of this e neigbour 468 ijea = 1 + ioea(ii,ij) / jpni ! ij index of this e neigbour 469 IF( ibondi(iiea,ijea) == 1 ) ibondi(iiea,ijea) = 2 ! this e neigbour had only a w neigbour -> no more neigbour 470 IF( ibondi(iiea,ijea) == 0 ) ibondi(iiea,ijea) = -1 ! this e neigbour had both, e-w neighbours -> keep e neigbour 471 ENDIF 472 ! land-only area with an active w neigbour 473 IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN 474 iiwe = 1 + MOD( iowe(ii,ij) , jpni ) ! ii index of this w neigbour 475 ijwe = 1 + iowe(ii,ij) / jpni ! ij index of this w neigbour 476 IF( ibondi(iiwe,ijwe) == -1 ) ibondi(iiwe,ijwe) = 2 ! this w neigbour had only a e neigbour -> no more neigbour 477 IF( ibondi(iiwe,ijwe) == 0 ) ibondi(iiwe,ijwe) = 1 ! this w neigbour had both, e-w neighbours -> keep w neigbour 478 ENDIF 479 END DO 480 481 ! 5. Subdomain print 482 ! ------------------ 483 IF(lwp) THEN 343 WRITE(numout,*) ' sum ijpj(1,j) = ', SUM(ijpj(1,:)), ' jpjglo = ', jpjglo 344 345 ! Subdomain grid print 484 346 ifreq = 4 485 347 il1 = 1 … … 504 366 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) 505 367 ENDIF 506 507 ! just to save nono etc for all proc 508 ! warning ii*ij (zone) /= nproc (processors)! 509 ! ioso = zone number, ii_noso = proc number 510 ii_noso(:) = -1 511 ii_nono(:) = -1 512 ii_noea(:) = -1 513 ii_nowe(:) = -1 514 DO jproc = 1, jpnij 515 ii = iin(jproc) 516 ij = ijn(jproc) 517 IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 518 iiso = 1 + MOD( ioso(ii,ij) , jpni ) 519 ijso = 1 + ioso(ii,ij) / jpni 520 ii_noso(jproc) = ipproc(iiso,ijso) 521 ENDIF 522 IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN 523 iiwe = 1 + MOD( iowe(ii,ij) , jpni ) 524 ijwe = 1 + iowe(ii,ij) / jpni 525 ii_nowe(jproc) = ipproc(iiwe,ijwe) 526 ENDIF 527 IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN 528 iiea = 1 + MOD( ioea(ii,ij) , jpni ) 529 ijea = 1 + ioea(ii,ij) / jpni 530 ii_noea(jproc)= ipproc(iiea,ijea) 531 ENDIF 532 IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN 533 iino = 1 + MOD( iono(ii,ij) , jpni ) 534 ijno = 1 + iono(ii,ij) / jpni 535 ii_nono(jproc)= ipproc(iino,ijno) 536 ENDIF 537 END DO 538 539 ! 6. Change processor name 540 ! ------------------------ 541 ii = iin(narea) 542 ij = ijn(narea) 543 ! 544 jpi = ijpi(ii,ij) 545 !!$ Nis0 = iis0(ii,ij) 546 !!$ Nie0 = iie0(ii,ij) 547 jpj = ijpj(ii,ij) 548 !!$ Njs0 = ijs0(ii,ij) 549 !!$ Nje0 = ije0(ii,ij) 550 nbondi = ibondi(ii,ij) 551 nbondj = ibondj(ii,ij) 552 nimpp = iimppt(ii,ij) 553 njmpp = ijmppt(ii,ij) 554 jpk = jpkglo ! third dim 555 556 ! set default neighbours 557 noso = ii_noso(narea) 558 nowe = ii_nowe(narea) 559 noea = ii_noea(narea) 560 nono = ii_nono(narea) 561 562 nones = -1 563 nonws = -1 564 noses = -1 565 nosws = -1 566 567 noner = -1 568 nonwr = -1 569 noser = -1 570 noswr = -1 571 572 IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists 573 IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN 574 nones = ii_nono(noea+1) ! east neighbour has north and south neighbours 575 noses = ii_noso(noea+1) 576 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN 577 nones = ii_nono(noea+1) ! east neighbour has north neighbour 578 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN 579 noses = ii_noso(noea+1) ! east neighbour has south neighbour 580 END IF 581 END IF 582 IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN ! west neighbour exists 583 IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN 584 nonws = ii_nono(nowe+1) ! west neighbour has north and south neighbours 585 nosws = ii_noso(nowe+1) 586 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN 587 nonws = ii_nono(nowe+1) ! west neighbour has north neighbour 588 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1) THEN 589 nosws = ii_noso(nowe+1) ! west neighbour has north neighbour 590 END IF 591 END IF 592 593 IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists 594 IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN 595 noner = ii_noea(nono+1) ! north neighbour has east and west neighbours 596 nonwr = ii_nowe(nono+1) 597 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN 598 noner = ii_noea(nono+1) ! north neighbour has east neighbour 599 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN 600 nonwr = ii_nowe(nono+1) ! north neighbour has west neighbour 601 END IF 602 END IF 603 IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN ! south neighbour exists 604 IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN 605 noser = ii_noea(noso+1) ! south neighbour has east and west neighbours 606 noswr = ii_nowe(noso+1) 607 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN 608 noser = ii_noea(noso+1) ! south neighbour has east neighbour 609 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN 610 noswr = ii_nowe(noso+1) ! south neighbour has west neighbour 611 END IF 612 END IF 613 614 ! 615 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 616 ! 617 jpim1 = jpi-1 ! inner domain indices 618 jpjm1 = jpj-1 ! " " 619 jpkm1 = MAX( 1, jpk-1 ) ! " " 620 jpij = jpi*jpj ! jpi x j 621 DO jproc = 1, jpnij 622 ii = iin(jproc) 623 ij = ijn(jproc) 624 jpiall (jproc) = ijpi(ii,ij) 625 nis0all(jproc) = iis0(ii,ij) 626 nie0all(jproc) = iie0(ii,ij) 627 jpjall (jproc) = ijpj(ii,ij) 628 njs0all(jproc) = ijs0(ii,ij) 629 nje0all(jproc) = ije0(ii,ij) 630 ibonit(jproc) = ibondi(ii,ij) 631 ibonjt(jproc) = ibondj(ii,ij) 632 nimppt(jproc) = iimppt(ii,ij) 633 njmppt(jproc) = ijmppt(ii,ij) 634 END DO 635 368 ! 369 ! Store informations for the north pole folding communications 370 nfproc(:) = ipproc(:,jpnj) 371 nfimpp(:) = iimppt(:,jpnj) 372 nfjpi (:) = ijpi(:,jpnj) 373 ! 374 ! 3. Define Western, Eastern, Southern and Northern neighbors + corners in the subdomain grid reference 375 ! ------------------------------------------------------------------------------------------------------ 376 ! 377 ! note that North fold is has specific treatment for its MPI communications. 378 ! This must not be treated as a "usual" communication with a northern neighbor. 379 ! -> North fold processes have no Northern neighbor in the definition done bellow 380 ! 381 llmpi_Iperio = jpni > 1 .AND. l_Iperio ! do i-periodicity with an MPI communication? 382 llmpi_Jperio = jpnj > 1 .AND. l_Jperio ! do j-periodicity with an MPI communication? 383 ! 384 l_SelfPerio(1:2) = l_Iperio .AND. jpni == 1 ! west, east periodicity by itself 385 l_SelfPerio(3:4) = l_Jperio .AND. jpnj == 1 ! south, north periodicity by itself 386 l_SelfPerio(5:8) = l_SelfPerio(jpwe) .AND. l_SelfPerio(jpso) ! corners bi-periodicity by itself 387 ! 388 ! define neighbors mapping (1/2): default definition: ignore if neighbours are land-only subdomains or not 389 DO jj = 1, jpnj 390 DO ji = 1, jpni 391 ! 392 IF ( llisOce(ji,jj) ) THEN ! this subdomain has some ocean: it has neighbours 393 ! 394 inum0 = ji - 1 + ( jj - 1 ) * jpni ! index in the subdomains grid. start at 0 395 ! 396 ! Is there a neighbor? 397 llnei(jpwe,ji,jj) = ji > 1 .OR. llmpi_Iperio ! West nei exists if not the first column or llmpi_Iperio 398 llnei(jpea,ji,jj) = ji < jpni .OR. llmpi_Iperio ! East nei exists if not the last column or llmpi_Iperio 399 llnei(jpso,ji,jj) = jj > 1 .OR. llmpi_Jperio ! South nei exists if not the first line or llmpi_Jperio 400 llnei(jpno,ji,jj) = jj < jpnj .OR. llmpi_Jperio ! North nei exists if not the last line or llmpi_Jperio 401 llnei(jpsw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpso,ji,jj) ! So-We nei exists if both South and West nei exist 402 llnei(jpse,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpso,ji,jj) ! So-Ea nei exists if both South and East nei exist 403 llnei(jpnw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpno,ji,jj) ! No-We nei exists if both North and West nei exist 404 llnei(jpne,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpno,ji,jj) ! No-Ea nei exists if both North and East nei exist 405 ! 406 ! Which index (starting at 0) have neighbors in the subdomains grid? 407 IF( llnei(jpwe,ji,jj) ) inei(jpwe,ji,jj) = inum0 - 1 + jpni * COUNT( (/ ji == 1 /) ) 408 IF( llnei(jpea,ji,jj) ) inei(jpea,ji,jj) = inum0 + 1 - jpni * COUNT( (/ ji == jpni /) ) 409 IF( llnei(jpso,ji,jj) ) inei(jpso,ji,jj) = inum0 - jpni + jpni * jpnj * COUNT( (/ jj == 1 /) ) 410 IF( llnei(jpno,ji,jj) ) inei(jpno,ji,jj) = inum0 + jpni - jpni * jpnj * COUNT( (/ jj == jpnj /) ) 411 IF( llnei(jpsw,ji,jj) ) inei(jpsw,ji,jj) = inei(jpso,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) 412 IF( llnei(jpse,ji,jj) ) inei(jpse,ji,jj) = inei(jpso,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) 413 IF( llnei(jpnw,ji,jj) ) inei(jpnw,ji,jj) = inei(jpno,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) 414 IF( llnei(jpne,ji,jj) ) inei(jpne,ji,jj) = inei(jpno,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) 415 ! 416 ELSE ! land-only domain has no neighbour 417 llnei(:,ji,jj) = .FALSE. 418 ENDIF 419 ! 420 END DO 421 END DO 422 ! 423 ! define neighbors mapping (2/2): check if neighbours are not land-only subdomains 424 DO jj = 1, jpnj 425 DO ji = 1, jpni 426 DO jn = 1, 8 427 IF( llnei(jn,ji,jj) ) THEN ! if a neighbour is existing -> this should not be a land-only domain 428 ii = 1 + MOD( inei(jn,ji,jj) , jpni ) 429 ij = 1 + inei(jn,ji,jj) / jpni 430 llnei(jn,ji,jj) = llisOce( ii, ij ) 431 ENDIF 432 END DO 433 END DO 434 END DO 435 ! 436 ! update index of the neighbours in the subdomains grid 437 WHERE( .NOT. llnei ) inei = -1 438 ! 636 439 ! Save processor layout in ascii file 637 440 IF (llwrtlay) THEN 638 441 CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 639 WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo'//& 640 & ' ( local: narea jpi jpj )' 641 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 642 & ' ( local: ',narea,jpi,jpj,' )' 643 WRITE(inum,'(a)') 'nproc jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 644 645 DO jproc = 1, jpnij 646 WRITE(inum,'(13i5,2i7)') jproc-1, jpiall(jproc), jpjall(jproc), & 647 & nis0all(jproc), njs0all(jproc), & 648 & nie0all(jproc), nje0all(jproc), & 649 & nimppt (jproc), njmppt (jproc), & 650 & ii_nono(jproc), ii_noso(jproc), & 651 & ii_nowe(jproc), ii_noea(jproc), & 652 & ibonit (jproc), ibonjt (jproc) 442 WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo ( local: narea jpi jpj )' 443 WRITE(inum,'(6i7,a,3i7,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,' ( local: ',narea,jpi,jpj,' )' 444 WRITE(inum,*) 445 WRITE(inum, *) '------------------------------------' 446 WRITE(inum,'(a,i2)') ' Mapping of the default neighnourgs ' 447 WRITE(inum, *) '------------------------------------' 448 WRITE(inum,*) 449 WRITE(inum,'(a)') ' rank ii ij jpi jpj nimpp njmpp mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 450 DO jp = 1, jpnij 451 ii = iin(jp) 452 ij = ijn(jp) 453 WRITE(inum,'(15i6)') jp-1, ii, ij, ijpi(ii,ij), ijpj(ii,ij), iimppt(ii,ij), ijmppt(ii,ij), inei(:,ii,ij) 653 454 END DO 654 END IF 655 656 ! ! north fold parameter 657 ! Defined npolj, either 0, 3 , 4 , 5 , 6 658 ! In this case the important thing is that npolj /= 0 659 ! Because if we go through these line it is because jpni >1 and thus 660 ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0 661 npolj = 0 662 ij = ijn(narea) 663 IF( jperio == 3 .OR. jperio == 4 ) THEN 664 IF( ij == jpnj ) npolj = 3 665 ENDIF 666 IF( jperio == 5 .OR. jperio == 6 ) THEN 667 IF( ij == jpnj ) npolj = 5 668 ENDIF 669 ! 670 nproc = narea-1 455 ENDIF 456 457 ! 458 ! 4. Define Western, Eastern, Southern and Northern neighbors + corners for each mpi process 459 ! ------------------------------------------------------------------------------------------ 460 ! 461 ! rewrite information from "subdomain grid" to mpi process list 462 ! Warning, for example: 463 ! position of the northern neighbor in the "subdomain grid" 464 ! position of the northern neighbor in the "mpi process list" 465 466 ! default definition: no neighbors 467 impi(:,:) = -1 ! (starting at 0, -1 if no neighbourg) 468 469 DO jp = 1, jpnij 470 ii = iin(jp) 471 ij = ijn(jp) 472 DO jn = 1, 8 473 IF( llnei(jn,ii,ij) ) THEN ! must be tested as some land-domain can be kept to fit mppsize 474 ii2 = 1 + MOD( inei(jn,ii,ij) , jpni ) 475 ij2 = 1 + inei(jn,ii,ij) / jpni 476 impi(jn,jp) = ipproc( ii2, ij2 ) 477 ENDIF 478 END DO 479 END DO 480 481 ! 482 ! 4. keep information for the local process 483 ! ----------------------------------------- 484 ! 485 ! set default neighbours 486 mpinei(:) = impi(:,narea) 487 DO jh = 1, n_hlsmax 488 mpiSnei(jh,:) = impi(:,narea) ! default definition 489 mpiRnei(jh,:) = impi(:,narea) 490 END DO 491 ! 671 492 IF(lwp) THEN 672 493 WRITE(numout,*) 673 494 WRITE(numout,*) ' resulting internal parameters : ' 674 WRITE(numout,*) ' nproc = ', nproc 675 WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea 676 WRITE(numout,*) ' nono = ', nono , ' noso = ', noso 677 WRITE(numout,*) ' nbondi = ', nbondi 678 WRITE(numout,*) ' nbondj = ', nbondj 679 WRITE(numout,*) ' npolj = ', npolj 680 WRITE(numout,*) ' l_Iperio = ', l_Iperio 681 WRITE(numout,*) ' l_Jperio = ', l_Jperio 682 WRITE(numout,*) ' nimpp = ', nimpp 683 WRITE(numout,*) ' njmpp = ', njmpp 684 ENDIF 685 495 WRITE(numout,*) ' narea = ', narea 496 WRITE(numout,*) ' mpi nei west = ', mpinei(jpwe) , ' mpi nei east = ', mpinei(jpea) 497 WRITE(numout,*) ' mpi nei south = ', mpinei(jpso) , ' mpi nei north = ', mpinei(jpno) 498 WRITE(numout,*) ' mpi nei so-we = ', mpinei(jpsw) , ' mpi nei so-ea = ', mpinei(jpse) 499 WRITE(numout,*) ' mpi nei no-we = ', mpinei(jpnw) , ' mpi nei no-ea = ', mpinei(jpne) 500 ENDIF 686 501 ! ! Prepare mpp north fold 687 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 502 ! 503 llmpiNFold = jpni > 1 .AND. l_NFold ! is the North fold done with an MPI communication? 504 l_IdoNFold = ijn(narea) == jpnj .AND. l_NFold ! is this process doing North fold? 505 ! 506 IF( llmpiNFold ) THEN 688 507 CALL mpp_ini_north 689 508 IF (lwp) THEN 690 509 WRITE(numout,*) 691 510 WRITE(numout,*) ' ==>>> North fold boundary prepared for jpni >1' 692 ! additional prints in layout.dat 693 ENDIF 694 IF (llwrtlay) THEN 511 ENDIF 512 IF (llwrtlay) THEN ! additional prints in layout.dat 695 513 WRITE(inum,*) 696 514 WRITE(inum,*) 697 WRITE(inum,*) ' number of subdomains located along the north fold : ', ndim_rank_north515 WRITE(inum,*) 'Number of subdomains located along the north fold : ', ndim_rank_north 698 516 WRITE(inum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north 699 DO jp roc= 1, ndim_rank_north, 5700 WRITE(inum,*) nrank_north( jp roc:MINVAL( (/jproc+4,ndim_rank_north/) ) )517 DO jp = 1, ndim_rank_north, 5 518 WRITE(inum,*) nrank_north( jp:MINVAL( (/jp+4,ndim_rank_north/) ) ) 701 519 END DO 702 520 ENDIF 703 ENDIF 704 705 ! 706 CALL mpp_ini_nc ! Initialize communicator for neighbourhood collective communications 707 ! 708 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 709 ! 710 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 711 CALL init_nfdcom ! northfold neighbour lists 712 IF (llwrtlay) THEN 713 WRITE(inum,*) 714 WRITE(inum,*) 715 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 716 WRITE(inum,*) 'nsndto : ', nsndto 717 WRITE(inum,*) 'isendto : ', isendto 718 ENDIF 719 ENDIF 521 IF ( l_IdoNFold .AND. ln_nnogather ) THEN 522 CALL init_nfdcom ! northfold neighbour lists 523 IF (llwrtlay) THEN 524 WRITE(inum,*) 525 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 526 WRITE(inum,*) ' nsndto : ', nsndto 527 WRITE(inum,*) ' isendto : ', isendto(1:nsndto) 528 ENDIF 529 ENDIF 530 ENDIF 531 ! 532 CALL mpp_ini_nc(nn_hls) ! Initialize communicator for neighbourhood collective communications 533 DO jh = 1, n_hlsmax 534 mpi_nc_com4(jh) = mpi_nc_com4(nn_hls) ! default definition 535 mpi_nc_com8(jh) = mpi_nc_com8(nn_hls) 536 END DO 537 ! 538 CALL init_excl_landpt ! exclude exchanges which contain only land points 539 ! 540 ! Save processor layout changes in ascii file 541 DO jh = 1, n_hlsmax ! different halo size 542 DO ji = 1, 8 543 ichanged(16*(jh-1) +ji) = COUNT( mpinei(ji:ji) /= mpiSnei(jh,ji:ji) ) 544 ichanged(16*(jh-1)+8+ji) = COUNT( mpinei(ji:ji) /= mpiRnei(jh,ji:ji) ) 545 END DO 546 END DO 547 CALL mpp_sum( "mpp_init", ichanged ) ! must be called by all processes 548 IF (llwrtlay) THEN 549 WRITE(inum,*) 550 WRITE(inum, *) '----------------------------------------------------------------------' 551 WRITE(inum,'(a,i2)') ' Mapping of the neighnourgs once excluding comm with only land points ' 552 WRITE(inum, *) '----------------------------------------------------------------------' 553 DO jh = 1, n_hlsmax ! different halo size 554 WRITE(inum,*) 555 WRITE(inum,'(a,i2)') 'halo size: ', jh 556 WRITE(inum, *) '---------' 557 WRITE(inum,'(a)') ' rank ii ij mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 558 WRITE(inum, '(11i6,a)') narea-1, iin(narea), ijn(narea), mpinei(:), ' <- Org' 559 WRITE(inum,'(18x,8i6,a,i1,a)') mpiSnei(jh,:), ' <- Send ', COUNT( mpinei(:) /= mpiSnei(jh,:) ), ' modif' 560 WRITE(inum,'(18x,8i6,a,i1,a)') mpiRnei(jh,:), ' <- Recv ', COUNT( mpinei(:) /= mpiRnei(jh,:) ), ' modif' 561 WRITE(inum,*) ' total changes among all mpi tasks:' 562 WRITE(inum,*) ' mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 563 WRITE(inum,'(a,8i6)') ' Send: ', ichanged(jh*16-15:jh*16-8) 564 WRITE(inum,'(a,8i6)') ' Recv: ', ichanged(jh*16 -7:jh*16 ) 565 END DO 566 ENDIF 567 ! 568 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 720 569 ! 721 570 IF (llwrtlay) CLOSE(inum) 722 571 ! 723 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 724 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 725 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 726 & iono, ioea, ioso, iowe, llisoce) 572 DEALLOCATE(iin, ijn, iimppt, ijmppt, ijpi, ijpj, ipproc, inei, llnei, impi, llisOce) 727 573 ! 728 574 END SUBROUTINE mpp_init … … 791 637 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 792 638 ENDIF 793 IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6) THEN639 IF( l_NFold ) THEN 794 640 ! minimize the size of the last row to compensate for the north pole folding coast 795 IF( jperio == 3 .OR. jperio == 4) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos796 IF( jperio == 5 .OR. jperio == 6) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos797 irm = knbj - irestj 798 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) 799 irm = irm - ( kjmax - klcj(1,knbj) ) 641 IF( c_NFtype == 'T' ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos 642 IF( c_NFtype == 'F' ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos 643 irm = knbj - irestj ! total number of lines to be removed 644 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 645 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 800 646 irestj = knbj - 1 - irm 801 647 klcj(:, irestj+1:knbj-1) = kjmax-1 … … 862 708 LOGICAL :: llist 863 709 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d ! max size of the subdomains along i,j 864 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llis oce ! - -710 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisOce ! - - 865 711 REAL(wp):: zpropland 866 712 !!---------------------------------------------------------------------- … … 885 731 iszimin = 4*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 886 732 iszjmin = 4*nn_hls 887 IF( jperio == 3 .OR. jperio == 4) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos888 IF( jperio == 5 .OR. jperio == 6) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos733 IF( c_NFtype == 'T' ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos 734 IF( c_NFtype == 'F' ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos 889 735 ! 890 736 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 935 781 iszi1(ii) = iszi0(ji) 936 782 iszj1(ii) = iszj0(jj) 937 END 783 ENDIF 938 784 END DO 939 785 END DO … … 991 837 WRITE(numout,*) ' -----------------------------------------------------' 992 838 WRITE(numout,*) 993 END 839 ENDIF 994 840 ji = isz0 ! initialization with the largest value 995 ALLOCATE( llis oce(inbi0(ji), inbj0(ji)) )996 CALL mpp_is_ocean( llis oce ) ! Warning: must be call by all cores (call mpp_sum)997 inbijold = COUNT(llis oce)998 DEALLOCATE( llis oce )841 ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) 842 CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) 843 inbijold = COUNT(llisOce) 844 DEALLOCATE( llisOce ) 999 845 DO ji =isz0-1,1,-1 1000 ALLOCATE( llis oce(inbi0(ji), inbj0(ji)) )1001 CALL mpp_is_ocean( llis oce ) ! Warning: must be call by all cores (call mpp_sum)1002 inbij = COUNT(llis oce)1003 DEALLOCATE( llis oce )846 ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) 847 CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) 848 inbij = COUNT(llisOce) 849 DEALLOCATE( llisOce ) 1004 850 IF(lwp .AND. inbij < inbijold) THEN 1005 851 WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & … … 1008 854 & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 1009 855 inbijold = inbij 1010 END 856 ENDIF 1011 857 END DO 1012 858 DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) … … 1024 870 DO WHILE( inbij > knbij ) ! while the number of ocean subdomains exceed the number of procs 1025 871 ii = ii -1 1026 ALLOCATE( llis oce(inbi0(ii), inbj0(ii)) )1027 CALL mpp_is_ocean( llis oce ) ! must be done by all core1028 inbij = COUNT(llis oce)1029 DEALLOCATE( llis oce )872 ALLOCATE( llisOce(inbi0(ii), inbj0(ii)) ) 873 CALL mpp_is_ocean( llisOce ) ! must be done by all core 874 inbij = COUNT(llisOce) 875 DEALLOCATE( llisOce ) 1030 876 END DO 1031 877 knbi = inbi0(ii) … … 1075 921 ! 1076 922 ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip 1077 CALL read bot_strip( ijstr, ijsz, lloce )923 CALL read_mask( 1, ijstr, Ni0glo, ijsz, lloce ) 1078 924 inboce = COUNT(lloce) ! number of ocean point in the stripe 1079 925 DEALLOCATE(lloce) … … 1089 935 1090 936 1091 SUBROUTINE mpp_is_ocean( ld isoce )937 SUBROUTINE mpp_is_ocean( ldIsOce ) 1092 938 !!---------------------------------------------------------------------- 1093 939 !! *** ROUTINE mpp_is_ocean *** … … 1097 943 !! at least 1 ocean point. 1098 944 !! We must indeed ensure that each subdomain that is a neighbour 1099 !! of a land subdomain 945 !! of a land subdomain, has only land points on its boundary 1100 946 !! (inside the inner subdomain) with the land subdomain. 1101 947 !! This is needed to get the proper bondary conditions on … … 1104 950 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1105 951 !!---------------------------------------------------------------------- 1106 LOGICAL, DIMENSION(:,:), INTENT( out) :: ld isoce ! .true. if a sub domain constains 1 ocean point952 LOGICAL, DIMENSION(:,:), INTENT( out) :: ldIsOce ! .true. if a sub domain constains 1 ocean point 1107 953 ! 1108 954 INTEGER :: idiv, iimax, ijmax, iarea … … 1117 963 ! do nothing if there is no land-sea mask 1118 964 IF( numbot == -1 .AND. numbdy == -1 ) THEN 1119 ld isoce(:,:) = .TRUE.965 ldIsOce(:,:) = .TRUE. 1120 966 RETURN 1121 967 ENDIF 1122 968 ! 1123 inbi = SIZE( ld isoce, dim = 1 )1124 inbj = SIZE( ld isoce, dim = 2 )969 inbi = SIZE( ldIsOce, dim = 1 ) 970 inbj = SIZE( ldIsOce, dim = 2 ) 1125 971 ! 1126 972 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 … … 1145 991 inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction 1146 992 isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? 1147 CALL read bot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip993 CALL read_mask( 1, ijmppt(1,iarea) - 2 + isty, Ni0glo, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip 1148 994 ! 1149 995 IF( iarea == 1 ) THEN ! the first line was not read 1150 IF( jperio == 2 .OR. jperio == 7 ) THEN! north-south periodocity1151 CALL read bot_strip( Nj0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce996 IF( l_Jperio ) THEN ! north-south periodocity 997 CALL read_mask( 1, Nj0glo, Ni0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce 1152 998 ELSE 1153 999 lloce(2:inx-1, 1) = .FALSE. ! closed boundary … … 1155 1001 ENDIF 1156 1002 IF( iarea == inbj ) THEN ! the last line was not read 1157 IF( jperio == 2 .OR. jperio == 7 ) THEN! north-south periodocity1158 CALL read bot_strip( 1, 1, lloce(2:inx-1,iny) )! read the first line -> last line of lloce1159 ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN! north-pole folding T-pivot, T-point1003 IF( l_Jperio ) THEN ! north-south periodocity 1004 CALL read_mask( 1, 1, Ni0glo, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce 1005 ELSEIF( c_NFtype == 'T' ) THEN ! north-pole folding T-pivot, T-point 1160 1006 lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) 1161 1007 DO ji = 3,inx-1 … … 1165 1011 lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 1166 1012 END DO 1167 ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN! north-pole folding F-pivot, T-point, 1 halo1013 ELSEIF( c_NFtype == 'F' ) THEN ! north-pole folding F-pivot, T-point, 1 halo 1168 1014 lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) 1169 1015 lloce(inx -1,iny-1) = lloce(2 ,iny-1) … … 1176 1022 ENDIF 1177 1023 ! ! first and last column were not read 1178 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) THEN1024 IF( l_Iperio ) THEN 1179 1025 lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity 1180 1026 ELSE … … 1195 1041 CALL mpp_sum( 'mppini', inboce_1d ) 1196 1042 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1197 ld isoce(:,:) = inboce(:,:) /= 01043 ldIsOce(:,:) = inboce(:,:) /= 0 1198 1044 DEALLOCATE(inboce, inboce_1d) 1199 1045 ! … … 1201 1047 1202 1048 1203 SUBROUTINE read bot_strip( kjstr, kjcnt, ldoce )1204 !!---------------------------------------------------------------------- 1205 !! *** ROUTINE read bot_strip***1049 SUBROUTINE read_mask( kistr, kjstr, kicnt, kjcnt, ldoce ) 1050 !!---------------------------------------------------------------------- 1051 !! *** ROUTINE read_mask *** 1206 1052 !! 1207 1053 !! ** Purpose : Read relevant bathymetric information in order to … … 1211 1057 !! ** Method : read stipe of size (Ni0glo,...) 1212 1058 !!---------------------------------------------------------------------- 1213 INTEGER , INTENT(in ) :: kjstr ! startingj position of the reading1214 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read1215 LOGICAL, DIMENSION( Ni0glo,kjcnt), INTENT( out) :: ldoce! ldoce(i,j) = .true. if the point (i,j) is ocean1216 ! 1217 INTEGER :: inumsave! local logical unit1218 REAL(wp), DIMENSION( Ni0glo,kjcnt) :: zbot, zbdy1059 INTEGER , INTENT(in ) :: kistr, kjstr ! starting i and j position of the reading 1060 INTEGER , INTENT(in ) :: kicnt, kjcnt ! number of points to read in i and j directions 1061 LOGICAL, DIMENSION(kicnt,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean 1062 ! 1063 INTEGER :: inumsave ! local logical unit 1064 REAL(wp), DIMENSION(kicnt,kjcnt) :: zbot, zbdy 1219 1065 !!---------------------------------------------------------------------- 1220 1066 ! … … 1222 1068 ! 1223 1069 IF( numbot /= -1 ) THEN 1224 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/ 1,kjstr/), kcount = (/Ni0glo, kjcnt/) )1070 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) 1225 1071 ELSE 1226 1072 zbot(:,:) = 1._wp ! put a non-null value … … 1228 1074 ! 1229 1075 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists 1230 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/ 1,kjstr/), kcount = (/Ni0glo, kjcnt/) )1076 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) 1231 1077 zbot(:,:) = zbot(:,:) * zbdy(:,:) 1232 1078 ENDIF 1233 1079 ! 1234 ldoce(:,:) = zbot(:,:) > 0._wp1080 ldoce(:,:) = NINT(zbot(:,:)) > 0 1235 1081 numout = inumsave 1236 1082 ! 1237 END SUBROUTINE read bot_strip1238 1239 1240 SUBROUTINE mpp_getnum( ld isoce, kproc, kipos, kjpos )1083 END SUBROUTINE read_mask 1084 1085 1086 SUBROUTINE mpp_getnum( ldIsOce, kproc, kipos, kjpos ) 1241 1087 !!---------------------------------------------------------------------- 1242 1088 !! *** ROUTINE mpp_getnum *** … … 1246 1092 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1247 1093 !!---------------------------------------------------------------------- 1248 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ld isoce ! F if land process1249 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0)1094 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldIsOce ! F if land process 1095 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if not existing, starting at 0) 1250 1096 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1251 1097 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) … … 1255 1101 !!---------------------------------------------------------------------- 1256 1102 ! 1257 ini = SIZE(ld isoce, dim = 1)1258 inj = SIZE(ld isoce, dim = 2)1103 ini = SIZE(ldIsOce, dim = 1) 1104 inj = SIZE(ldIsOce, dim = 2) 1259 1105 inij = SIZE(kipos) 1260 1106 ! … … 1266 1112 ii = 1 + MOD(iarea0,ini) 1267 1113 ij = 1 + iarea0/ini 1268 IF( ld isoce(ii,ij) ) THEN1114 IF( ldIsOce(ii,ij) ) THEN 1269 1115 icont = icont + 1 1270 1116 kproc(ii,ij) = icont … … 1274 1120 END DO 1275 1121 ! if needed add some land subdomains to reach inij active subdomains 1276 i2add = inij - COUNT( ld isoce )1122 i2add = inij - COUNT( ldIsOce ) 1277 1123 DO jarea = 1, ini*inj 1278 1124 iarea0 = jarea - 1 1279 1125 ii = 1 + MOD(iarea0,ini) 1280 1126 ij = 1 + iarea0/ini 1281 IF( .NOT. ld isoce(ii,ij) .AND. i2add > 0 ) THEN1127 IF( .NOT. ldIsOce(ii,ij) .AND. i2add > 0 ) THEN 1282 1128 icont = icont + 1 1283 1129 kproc(ii,ij) = icont … … 1289 1135 ! 1290 1136 END SUBROUTINE mpp_getnum 1137 1138 1139 SUBROUTINE init_excl_landpt 1140 !!---------------------------------------------------------------------- 1141 !! *** ROUTINE *** 1142 !! 1143 !! ** Purpose : exclude exchanges which contain only land points 1144 !! 1145 !! ** Method : if a send or receive buffer constains only land point we 1146 !! flag off the corresponding communication 1147 !! Warning: this selection depend on the halo size -> loop on halo size 1148 !! 1149 !!---------------------------------------------------------------------- 1150 INTEGER :: inumsave 1151 INTEGER :: jh 1152 INTEGER :: ipi, ipj 1153 INTEGER :: iiwe, iiea, iist, iisz 1154 INTEGER :: ijso, ijno, ijst, ijsz 1155 LOGICAL :: llsave 1156 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zmsk 1157 LOGICAL , DIMENSION(Ni_0,Nj_0,1) :: lloce 1158 !!---------------------------------------------------------------------- 1159 ! 1160 ! read the land-sea mask on the inner domain 1161 CALL read_mask( nimpp, njmpp, Ni_0, Nj_0, lloce(:,:,1) ) 1162 ! 1163 ! Here we look only at communications excluding the NP folding. 1164 ! As lbcnfd not validated if halo size /= nn_hls, we switch if off temporary... 1165 llsave = l_IdoNFold 1166 l_IdoNFold = .FALSE. 1167 ! 1168 DO jh = 1, n_hlsmax ! different halo size 1169 ! 1170 ipi = Ni_0 + 2*jh ! local domain size 1171 ipj = Nj_0 + 2*jh 1172 ! 1173 ALLOCATE( zmsk(ipi,ipj) ) 1174 zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3), wp) ! define inner domain -> need REAL to use lbclnk 1175 CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos 1176 ! 1177 iiwe = jh ; iiea = Ni_0 ! bottom-left corfer - 1 of the sent data 1178 ijso = jh ; ijno = Nj_0 1179 IF( nn_comm == 1 ) THEN 1180 iist = 0 ; iisz = ipi 1181 ijst = 0 ; ijsz = ipj 1182 ELSE 1183 iist = jh ; iisz = Ni_0 1184 ijst = jh ; ijsz = Nj_0 1185 ENDIF 1186 IF( nn_comm == 1 ) THEN ! SM: NOT WORKING FOR NEIGHBOURHOOD COLLECTIVE COMMUNICATIONS, I DON'T KNOW WHY... 1187 ! do not send if we send only land points 1188 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiSnei(jh,jpwe) = -1 1189 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiSnei(jh,jpea) = -1 1190 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpso) = -1 1191 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpno) = -1 1192 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpsw) = -1 1193 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpse) = -1 1194 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpnw) = -1 1195 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpne) = -1 1196 ! 1197 iiwe = iiwe-jh ; iiea = iiea+jh ! bottom-left corfer - 1 of the received data 1198 ijso = ijso-jh ; ijno = ijno+jh 1199 ! do not send if we send only land points 1200 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiRnei(jh,jpwe) = -1 1201 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiRnei(jh,jpea) = -1 1202 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpso) = -1 1203 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpno) = -1 1204 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpsw) = -1 1205 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpse) = -1 1206 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpnw) = -1 1207 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpne) = -1 1208 ENDIF 1209 ! 1210 ! Specific (and rare) problem in corner treatment because we do 1st West-East comm, next South-North comm 1211 IF( nn_comm == 1 ) THEN 1212 IF( mpiSnei(jh,jpwe) > -1 ) mpiSnei(jh, (/jpsw,jpnw/) ) = -1 ! SW and NW corners already sent through West nei 1213 IF( mpiSnei(jh,jpea) > -1 ) mpiSnei(jh, (/jpse,jpne/) ) = -1 ! SE and NE corners already sent through East nei 1214 IF( mpiRnei(jh,jpso) > -1 ) mpiRnei(jh, (/jpsw,jpse/) ) = -1 ! SW and SE corners will be received through South nei 1215 IF( mpiRnei(jh,jpno) > -1 ) mpiRnei(jh, (/jpnw,jpne/) ) = -1 ! NW and NE corners will be received through North nei 1216 ENDIF 1217 ! 1218 DEALLOCATE( zmsk ) 1219 ! 1220 CALL mpp_ini_nc(jh) ! Initialize/Update communicator for neighbourhood collective communications 1221 ! 1222 END DO 1223 l_IdoNFold = llsave 1224 1225 END SUBROUTINE init_excl_landpt 1291 1226 1292 1227 … … 1326 1261 ENDIF 1327 1262 ! 1328 CALL flio_dom_set ( jpnij, n proc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom)1263 CALL flio_dom_set ( jpnij, narea-1, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) 1329 1264 ! 1330 1265 END SUBROUTINE init_ioipsl … … 1345 1280 !!---------------------------------------------------------------------- 1346 1281 ! 1347 !initializes the north-fold communication variables 1348 isendto(:) = 0 1349 nsndto = 0 1350 ! 1351 IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north 1282 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1283 sxM = jpiglo - nimpp - jpi + 1 1284 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1285 dxM = jpiglo - nimpp + 2 1286 ! 1287 ! loop over the other north-fold processes to find the processes 1288 ! managing the points belonging to the sxT-dxT range 1289 ! 1290 nsndto = 0 1291 DO jn = 1, jpni 1352 1292 ! 1353 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1354 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1355 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1356 dxM = jpiglo - nimppt(narea) + 2 1293 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1294 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1357 1295 ! 1358 ! loop over the other north-fold processes to find the processes 1359 ! managing the points belonging to the sxT-dxT range 1296 IF ( sxT < sxM .AND. sxM < dxT ) THEN 1297 nsndto = nsndto + 1 1298 isendto(nsndto) = jn 1299 ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN 1300 nsndto = nsndto + 1 1301 isendto(nsndto) = jn 1302 ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN 1303 nsndto = nsndto + 1 1304 isendto(nsndto) = jn 1305 ENDIF 1360 1306 ! 1361 DO jn = 1, jpni 1362 ! 1363 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1364 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1365 ! 1366 IF ( sxT < sxM .AND. sxM < dxT ) THEN 1367 nsndto = nsndto + 1 1368 isendto(nsndto) = jn 1369 ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN 1370 nsndto = nsndto + 1 1371 isendto(nsndto) = jn 1372 ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN 1373 nsndto = nsndto + 1 1374 isendto(nsndto) = jn 1375 ENDIF 1376 ! 1377 END DO 1378 ! 1379 ENDIF 1380 l_north_nogather = .TRUE. 1307 END DO 1381 1308 ! 1382 1309 END SUBROUTINE init_nfdcom … … 1391 1318 !!---------------------------------------------------------------------- 1392 1319 ! 1393 Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2) 1394 Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2) 1395 ! 1396 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1397 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1398 ! 1399 IF( nn_hls == 1 ) THEN !* halo size of 1 1400 ! 1401 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0 1402 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0 1403 ! 1404 ELSE !* larger halo size... 1405 ! 1406 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1 1407 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1 1408 ! 1409 ENDIF 1320 Nis0 = 1+nn_hls 1321 Njs0 = 1+nn_hls 1322 Nie0 = jpi-nn_hls 1323 Nje0 = jpj-nn_hls 1410 1324 ! 1411 1325 Ni_0 = Nie0 - Nis0 + 1 1412 1326 Nj_0 = Nje0 - Njs0 + 1 1413 Ni_1 = Nie1 - Nis1 + 1 1414 Nj_1 = Nje1 - Njs1 + 1 1415 Ni_2 = Nie2 - Nis2 + 1 1416 Nj_2 = Nje2 - Njs2 + 1 1327 ! 1328 ! old indices to be removed... 1329 jpim1 = jpi-1 ! inner domain indices 1330 jpjm1 = jpj-1 ! " " 1331 jpkm1 = jpk-1 ! " " 1417 1332 ! 1418 1333 END SUBROUTINE init_doloop
Note: See TracChangeset
for help on using the changeset viewer.