Changeset 14433 for NEMO/trunk/src/OCE/LBC
- Timestamp:
- 2021-02-11T09:06:49+01:00 (3 years ago)
- Location:
- NEMO/trunk/src/OCE/LBC
- Files:
-
- 4 deleted
- 10 edited
- 3 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk/src/OCE/LBC/lbc_nfd_ext_generic.h90
r13286 r14433 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/trunk/src/OCE/LBC/lbc_nfd_generic.h90
r13286 r14433 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/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r13286 r14433 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/trunk/src/OCE/LBC/lbclnk.F90
r14229 r14433 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/trunk/src/OCE/LBC/lbcnfd.F90
r13286 r14433 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/trunk/src/OCE/LBC/lib_mpp.F90
r14354 r14433 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 … … 130 138 INTEGER :: MPI_SUMDD 131 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 132 157 ! variables used for zonal integration 133 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average134 LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row135 INTEGER :: ngrp_znl !group ID for the znl processors136 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 137 162 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 138 163 139 164 ! variables used for MPI3 neighbourhood collectives 140 INTEGER, PUBLIC :: mpi_nc_com! MPI3 neighbourhood collectives communicator141 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) 142 167 143 168 ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) … … 185 210 186 211 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 187 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 188 219 189 220 !! * Substitutions … … 263 294 INTEGER , INTENT(in ) :: kdest ! receive process number 264 295 INTEGER , INTENT(in ) :: ktyp ! tag of the message 265 INTEGER , INTENT(in 296 INTEGER , INTENT(inout) :: md_req ! argument for isend 266 297 !! 267 298 INTEGER :: iflag … … 292 323 INTEGER , INTENT(in ) :: kdest ! receive process number 293 324 INTEGER , INTENT(in ) :: ktyp ! tag of the message 294 INTEGER , INTENT(in 325 INTEGER , INTENT(inout) :: md_req ! argument for isend 295 326 !! 296 327 INTEGER :: iflag … … 315 346 INTEGER , INTENT(in ) :: kdest ! receive process number 316 347 INTEGER , INTENT(in ) :: ktyp ! tag of the message 317 INTEGER , INTENT(in 348 INTEGER , INTENT(inout) :: md_req ! argument for isend 318 349 !! 319 350 INTEGER :: iflag … … 942 973 LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number 943 974 LOGICAL :: ll_abort 944 INTEGER :: info 975 INTEGER :: info, ierr 945 976 !!---------------------------------------------------------------------- 946 977 ll_abort = .FALSE. … … 949 980 #if ! defined key_mpi_off 950 981 IF(ll_abort) THEN 951 CALL mpi_abort( MPI_COMM_WORLD )982 CALL mpi_abort( MPI_COMM_WORLD, 123, info ) 952 983 ELSE 953 984 CALL mppsync … … 962 993 SUBROUTINE mpp_comm_free( kcom ) 963 994 !!---------------------------------------------------------------------- 964 INTEGER, INTENT(in ) :: kcom995 INTEGER, INTENT(inout) :: kcom 965 996 !! 966 997 INTEGER :: ierr … … 1071 1102 END SUBROUTINE mpp_ini_znl 1072 1103 1073 SUBROUTINE mpp_ini_nc 1104 1105 SUBROUTINE mpp_ini_nc( khls ) 1074 1106 !!---------------------------------------------------------------------- 1075 1107 !! *** routine mpp_ini_nc *** … … 1082 1114 ! 1083 1115 !! ** output 1084 !! mpi_nc_com = MPI3 neighbourhood collectives communicator 1085 !! mpi_nc_all_com = MPI3 neighbourhood collectives communicator 1086 !! (with diagonals) 1087 !! 1088 !!---------------------------------------------------------------------- 1089 INTEGER, DIMENSION(:), ALLOCATABLE :: ineigh, ineighalls, ineighallr 1090 INTEGER :: ideg, idegalls, idegallr, icont, icont1 1091 INTEGER :: ierr 1092 LOGICAL, PARAMETER :: ireord = .FALSE. 1093 1094 #if ! defined key_mpi_off 1095 1096 ideg = 0 1097 idegalls = 0 1098 idegallr = 0 1099 icont = 0 1100 icont1 = 0 1101 1102 IF (nbondi .eq. 1) THEN 1103 ideg = ideg + 1 1104 ELSEIF (nbondi .eq. -1) THEN 1105 ideg = ideg + 1 1106 ELSEIF (nbondi .eq. 0) THEN 1107 ideg = ideg + 2 1108 ENDIF 1109 1110 IF (nbondj .eq. 1) THEN 1111 ideg = ideg + 1 1112 ELSEIF (nbondj .eq. -1) THEN 1113 ideg = ideg + 1 1114 ELSEIF (nbondj .eq. 0) THEN 1115 ideg = ideg + 2 1116 ENDIF 1117 1118 idegalls = ideg 1119 idegallr = ideg 1120 1121 IF (nones .ne. -1) idegalls = idegalls + 1 1122 IF (nonws .ne. -1) idegalls = idegalls + 1 1123 IF (noses .ne. -1) idegalls = idegalls + 1 1124 IF (nosws .ne. -1) idegalls = idegalls + 1 1125 IF (noner .ne. -1) idegallr = idegallr + 1 1126 IF (nonwr .ne. -1) idegallr = idegallr + 1 1127 IF (noser .ne. -1) idegallr = idegallr + 1 1128 IF (noswr .ne. -1) idegallr = idegallr + 1 1129 1130 ALLOCATE(ineigh(ideg)) 1131 ALLOCATE(ineighalls(idegalls)) 1132 ALLOCATE(ineighallr(idegallr)) 1133 1134 IF (nbondi .eq. 1) THEN 1135 icont = icont + 1 1136 ineigh(icont) = nowe 1137 ineighalls(icont) = nowe 1138 ineighallr(icont) = nowe 1139 ELSEIF (nbondi .eq. -1) THEN 1140 icont = icont + 1 1141 ineigh(icont) = noea 1142 ineighalls(icont) = noea 1143 ineighallr(icont) = noea 1144 ELSEIF (nbondi .eq. 0) THEN 1145 icont = icont + 1 1146 ineigh(icont) = nowe 1147 ineighalls(icont) = nowe 1148 ineighallr(icont) = nowe 1149 icont = icont + 1 1150 ineigh(icont) = noea 1151 ineighalls(icont) = noea 1152 ineighallr(icont) = noea 1153 ENDIF 1154 1155 IF (nbondj .eq. 1) THEN 1156 icont = icont + 1 1157 ineigh(icont) = noso 1158 ineighalls(icont) = noso 1159 ineighallr(icont) = noso 1160 ELSEIF (nbondj .eq. -1) THEN 1161 icont = icont + 1 1162 ineigh(icont) = nono 1163 ineighalls(icont) = nono 1164 ineighallr(icont) = nono 1165 ELSEIF (nbondj .eq. 0) THEN 1166 icont = icont + 1 1167 ineigh(icont) = noso 1168 ineighalls(icont) = noso 1169 ineighallr(icont) = noso 1170 icont = icont + 1 1171 ineigh(icont) = nono 1172 ineighalls(icont) = nono 1173 ineighallr(icont) = nono 1174 ENDIF 1175 1176 icont1 = icont 1177 IF (nosws .ne. -1) THEN 1178 icont = icont + 1 1179 ineighalls(icont) = nosws 1180 ENDIF 1181 IF (noses .ne. -1) THEN 1182 icont = icont + 1 1183 ineighalls(icont) = noses 1184 ENDIF 1185 IF (nonws .ne. -1) THEN 1186 icont = icont + 1 1187 ineighalls(icont) = nonws 1188 ENDIF 1189 IF (nones .ne. -1) THEN 1190 icont = icont + 1 1191 ineighalls(icont) = nones 1192 ENDIF 1193 IF (noswr .ne. -1) THEN 1194 icont1 = icont1 + 1 1195 ineighallr(icont1) = noswr 1196 ENDIF 1197 IF (noser .ne. -1) THEN 1198 icont1 = icont1 + 1 1199 ineighallr(icont1) = noser 1200 ENDIF 1201 IF (nonwr .ne. -1) THEN 1202 icont1 = icont1 + 1 1203 ineighallr(icont1) = nonwr 1204 ENDIF 1205 IF (noner .ne. -1) THEN 1206 icont1 = icont1 + 1 1207 ineighallr(icont1) = noner 1208 ENDIF 1209 1210 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) 1211 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) 1212 1213 DEALLOCATE (ineigh) 1214 DEALLOCATE (ineighalls) 1215 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 ) 1216 1146 #endif 1217 1147 END SUBROUTINE mpp_ini_nc 1218 1219 1148 1220 1149 … … 1232 1161 !! 1233 1162 !! ** output 1234 !! njmppmax = njmpp for northern procs1235 1163 !! ndim_rank_north = number of processors in the northern line 1236 1164 !! nrank_north (ndim_rank_north) = number of the northern procs. … … 1247 1175 ! 1248 1176 #if ! defined key_mpi_off 1249 njmppmax = MAXVAL( njmppt )1250 1177 ! 1251 1178 ! Look for how many procs on the northern boundary -
NEMO/trunk/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
r14229 r14433 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/trunk/src/OCE/LBC/mpp_lnk_icb_generic.h90
r13286 r14433 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/trunk/src/OCE/LBC/mpp_nfd_generic.h90
r14229 r14433 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/trunk/src/OCE/LBC/mppini.F90
r14275 r14433 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 !! noea : number for local neighboring processor 136 !! nowe : number for local neighboring processor 137 !! noso : number for local neighboring processor 138 !! nono : number for local neighboring processor 139 !!---------------------------------------------------------------------- 140 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 141 INTEGER :: inijmin 142 INTEGER :: inum ! local logical unit 143 INTEGER :: idir, ifreq ! local integers 144 INTEGER :: ii, il1, ili, imil ! - - 145 INTEGER :: ij, il2, ilj, ijm1 ! - - 146 INTEGER :: iino, ijno, iiso, ijso ! - - 147 INTEGER :: iiea, ijea, iiwe, ijwe ! - - 148 INTEGER :: iarea0 ! - - 149 INTEGER :: ierr, ios ! 150 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 151 136 LOGICAL :: llbest, llauto 152 137 LOGICAL :: llwrtlay 138 LOGICAL :: llmpi_Iperio, llmpi_Jperio, llmpiNFold 153 139 LOGICAL :: ln_listonly 154 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 155 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 156 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 157 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 158 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 159 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 160 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 140 LOGICAL, ALLOCATABLE, DIMENSION(:,: ) :: llisOce ! is not land-domain only? 141 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: llnei ! are neighbourgs existing? 161 142 NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & 162 143 & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & … … 165 146 & cn_ice, nn_ice_dta, & 166 147 & ln_vol, nn_volctl, nn_rimwidth 167 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 148 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly, nn_comm 168 149 !!---------------------------------------------------------------------- 169 150 ! … … 193 174 IF(lwm) WRITE( numond, nammpp ) 194 175 ! 195 !!!------------------------------------196 !!! nn_hls shloud be read in nammpp197 !!!------------------------------------198 176 jpiglo = Ni0glo + 2 * nn_hls 199 177 jpjglo = Nj0glo + 2 * nn_hls … … 213 191 ! ----------------------------------- 214 192 ! 215 ! 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 216 194 ! then we calculate them here now that we have our communicator size 217 195 IF(lwp) THEN … … 260 238 261 239 ! look for land mpi subdomains... 262 ALLOCATE( llis oce(jpni,jpnj) )263 CALL mpp_is_ocean( llis oce )264 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 265 243 266 244 IF( mppsize < inijmin ) THEN ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... … … 319 297 9003 FORMAT (a, i5) 320 298 321 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 322 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 323 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 324 & nie0all(jpnij) , nje0all(jpnij) , & 325 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 326 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 327 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 328 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 329 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 330 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 331 & 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 ) 332 305 CALL mpp_sum( 'mppini', ierr ) 333 306 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' ) … … 343 316 ! 344 317 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 345 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 346 ! 347 !DO jn = 1, jpni 348 ! jproc = ipproc(jn,jpnj) 349 ! ii = iin(jproc+1) 350 ! ij = ijn(jproc+1) 351 ! nfproc(jn) = jproc 352 ! nfimpp(jn) = iimppt(ii,ij) 353 ! nfjpi (jn) = ijpi(ii,ij) 354 !END DO 355 nfproc(:) = ipproc(:,jpnj) 356 nfimpp(:) = iimppt(:,jpnj) 357 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) 358 330 ! 359 331 IF(lwp) THEN … … 365 337 WRITE(numout,*) ' jpnj = ', jpnj 366 338 WRITE(numout,*) ' jpnij = ', jpnij 339 WRITE(numout,*) ' nimpp = ', nimpp 340 WRITE(numout,*) ' njmpp = ', njmpp 367 341 WRITE(numout,*) 368 342 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 369 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 370 ENDIF 371 372 ! 3. Subdomain description in the Regular Case 373 ! -------------------------------------------- 374 ! specific cases where there is no communication -> must do the periodicity by itself 375 ! Warning: because of potential land-area suppression, do not use nbond[ij] == 2 376 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 377 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 378 379 DO jarea = 1, jpni*jpnj 380 ! 381 iarea0 = jarea - 1 382 ii = 1 + MOD(iarea0,jpni) 383 ij = 1 + iarea0/jpni 384 ili = ijpi(ii,ij) 385 ilj = ijpj(ii,ij) 386 ibondi(ii,ij) = 0 ! default: has e-w neighbours 387 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour 388 IF( ii == jpni ) ibondi(ii,ij) = 1 ! last column, has only w neighbour 389 IF( jpni == 1 ) ibondi(ii,ij) = 2 ! has no e-w neighbour 390 ibondj(ii,ij) = 0 ! default: has n-s neighbours 391 IF( ij == 1 ) ibondj(ii,ij) = -1 ! first row, has only n neighbour 392 IF( ij == jpnj ) ibondj(ii,ij) = 1 ! last row, has only s neighbour 393 IF( jpnj == 1 ) ibondj(ii,ij) = 2 ! has no n-s neighbour 394 395 ! Subdomain neighbors (get their zone number): default definition 396 ioso(ii,ij) = iarea0 - jpni 397 iowe(ii,ij) = iarea0 - 1 398 ioea(ii,ij) = iarea0 + 1 399 iono(ii,ij) = iarea0 + jpni 400 iis0(ii,ij) = 1 + nn_hls 401 iie0(ii,ij) = ili - nn_hls 402 ijs0(ii,ij) = 1 + nn_hls 403 ije0(ii,ij) = ilj - nn_hls 404 405 ! East-West periodicity: change ibondi, ioea, iowe 406 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 407 IF( jpni /= 1 ) ibondi(ii,ij) = 0 ! redefine: all have e-w neighbours 408 IF( ii == 1 ) iowe(ii,ij) = iarea0 + (jpni-1) ! redefine: first column, address of w neighbour 409 IF( ii == jpni ) ioea(ii,ij) = iarea0 - (jpni-1) ! redefine: last column, address of e neighbour 410 ENDIF 411 412 ! Simple North-South periodicity: change ibondj, ioso, iono 413 IF( jperio == 2 .OR. jperio == 7 ) THEN 414 IF( jpnj /= 1 ) ibondj(ii,ij) = 0 ! redefine: all have n-s neighbours 415 IF( ij == 1 ) ioso(ii,ij) = iarea0 + jpni * (jpnj-1) ! redefine: first row, address of s neighbour 416 IF( ij == jpnj ) iono(ii,ij) = iarea0 - jpni * (jpnj-1) ! redefine: last row, address of n neighbour 417 ENDIF 418 419 ! North fold: define ipolj, change iono. Warning: we do not change ibondj... 420 ipolj(ii,ij) = 0 421 IF( jperio == 3 .OR. jperio == 4 ) THEN 422 ijm1 = jpni*(jpnj-1) 423 imil = ijm1+(jpni+1)/2 424 IF( jarea > ijm1 ) ipolj(ii,ij) = 3 425 IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4 426 IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour 427 ENDIF 428 IF( jperio == 5 .OR. jperio == 6 ) THEN 429 ijm1 = jpni*(jpnj-1) 430 imil = ijm1+(jpni+1)/2 431 IF( jarea > ijm1) ipolj(ii,ij) = 5 432 IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6 433 IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour 434 ENDIF 435 ! 436 END DO 437 438 ! 4. deal with land subdomains 439 ! ---------------------------- 440 ! 441 ! neighbour treatment: change ibondi, ibondj if next to a land zone 442 DO jarea = 1, jpni*jpnj 443 ii = 1 + MOD( jarea-1 , jpni ) 444 ij = 1 + (jarea-1) / jpni 445 ! land-only area with an active n neigbour 446 IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN 447 iino = 1 + MOD( iono(ii,ij) , jpni ) ! ii index of this n neigbour 448 ijno = 1 + iono(ii,ij) / jpni ! ij index of this n neigbour 449 ! In case of north fold exchange: I am the n neigbour of my n neigbour!! (#1057) 450 ! --> for northern neighbours of northern row processors (in case of north-fold) 451 ! need to reverse the LOGICAL direction of communication 452 idir = 1 ! we are indeed the s neigbour of this n neigbour 453 IF( ij == jpnj .AND. ijno == jpnj ) idir = -1 ! both are on the last row, we are in fact the n neigbour 454 IF( ibondj(iino,ijno) == idir ) ibondj(iino,ijno) = 2 ! this n neigbour had only a s/n neigbour -> no more 455 IF( ibondj(iino,ijno) == 0 ) ibondj(iino,ijno) = -idir ! this n neigbour had both, n-s neighbours -> keep 1 456 ENDIF 457 ! land-only area with an active s neigbour 458 IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN 459 iiso = 1 + MOD( ioso(ii,ij) , jpni ) ! ii index of this s neigbour 460 ijso = 1 + ioso(ii,ij) / jpni ! ij index of this s neigbour 461 IF( ibondj(iiso,ijso) == -1 ) ibondj(iiso,ijso) = 2 ! this s neigbour had only a n neigbour -> no more neigbour 462 IF( ibondj(iiso,ijso) == 0 ) ibondj(iiso,ijso) = 1 ! this s neigbour had both, n-s neighbours -> keep s neigbour 463 ENDIF 464 ! land-only area with an active e neigbour 465 IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN 466 iiea = 1 + MOD( ioea(ii,ij) , jpni ) ! ii index of this e neigbour 467 ijea = 1 + ioea(ii,ij) / jpni ! ij index of this e neigbour 468 IF( ibondi(iiea,ijea) == 1 ) ibondi(iiea,ijea) = 2 ! this e neigbour had only a w neigbour -> no more neigbour 469 IF( ibondi(iiea,ijea) == 0 ) ibondi(iiea,ijea) = -1 ! this e neigbour had both, e-w neighbours -> keep e neigbour 470 ENDIF 471 ! land-only area with an active w neigbour 472 IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN 473 iiwe = 1 + MOD( iowe(ii,ij) , jpni ) ! ii index of this w neigbour 474 ijwe = 1 + iowe(ii,ij) / jpni ! ij index of this w neigbour 475 IF( ibondi(iiwe,ijwe) == -1 ) ibondi(iiwe,ijwe) = 2 ! this w neigbour had only a e neigbour -> no more neigbour 476 IF( ibondi(iiwe,ijwe) == 0 ) ibondi(iiwe,ijwe) = 1 ! this w neigbour had both, e-w neighbours -> keep w neigbour 477 ENDIF 478 END DO 479 480 ! 5. Subdomain print 481 ! ------------------ 482 IF(lwp) THEN 343 WRITE(numout,*) ' sum ijpj(1,j) = ', SUM(ijpj(1,:)), ' jpjglo = ', jpjglo 344 345 ! Subdomain grid print 483 346 ifreq = 4 484 347 il1 = 1 … … 503 366 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) 504 367 ENDIF 505 506 ! just to save nono etc for all proc 507 ! warning ii*ij (zone) /= mpprank (processors)! 508 ! ioso = zone number, ii_noso = proc number 509 ii_noso(:) = -1 510 ii_nono(:) = -1 511 ii_noea(:) = -1 512 ii_nowe(:) = -1 513 DO jproc = 1, jpnij 514 ii = iin(jproc) 515 ij = ijn(jproc) 516 IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 517 iiso = 1 + MOD( ioso(ii,ij) , jpni ) 518 ijso = 1 + ioso(ii,ij) / jpni 519 ii_noso(jproc) = ipproc(iiso,ijso) 520 ENDIF 521 IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN 522 iiwe = 1 + MOD( iowe(ii,ij) , jpni ) 523 ijwe = 1 + iowe(ii,ij) / jpni 524 ii_nowe(jproc) = ipproc(iiwe,ijwe) 525 ENDIF 526 IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN 527 iiea = 1 + MOD( ioea(ii,ij) , jpni ) 528 ijea = 1 + ioea(ii,ij) / jpni 529 ii_noea(jproc)= ipproc(iiea,ijea) 530 ENDIF 531 IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN 532 iino = 1 + MOD( iono(ii,ij) , jpni ) 533 ijno = 1 + iono(ii,ij) / jpni 534 ii_nono(jproc)= ipproc(iino,ijno) 535 ENDIF 536 END DO 537 538 ! 6. Change processor name 539 ! ------------------------ 540 ii = iin(narea) 541 ij = ijn(narea) 542 ! 543 jpi = ijpi(ii,ij) 544 !!$ Nis0 = iis0(ii,ij) 545 !!$ Nie0 = iie0(ii,ij) 546 jpj = ijpj(ii,ij) 547 !!$ Njs0 = ijs0(ii,ij) 548 !!$ Nje0 = ije0(ii,ij) 549 nbondi = ibondi(ii,ij) 550 nbondj = ibondj(ii,ij) 551 nimpp = iimppt(ii,ij) 552 njmpp = ijmppt(ii,ij) 553 jpk = jpkglo ! third dim 554 555 ! set default neighbours 556 noso = ii_noso(narea) 557 nowe = ii_nowe(narea) 558 noea = ii_noea(narea) 559 nono = ii_nono(narea) 560 561 nones = -1 562 nonws = -1 563 noses = -1 564 nosws = -1 565 566 noner = -1 567 nonwr = -1 568 noser = -1 569 noswr = -1 570 571 IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists 572 IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN 573 nones = ii_nono(noea+1) ! east neighbour has north and south neighbours 574 noses = ii_noso(noea+1) 575 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN 576 nones = ii_nono(noea+1) ! east neighbour has north neighbour 577 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN 578 noses = ii_noso(noea+1) ! east neighbour has south neighbour 579 END IF 580 END IF 581 IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN ! west neighbour exists 582 IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN 583 nonws = ii_nono(nowe+1) ! west neighbour has north and south neighbours 584 nosws = ii_noso(nowe+1) 585 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN 586 nonws = ii_nono(nowe+1) ! west neighbour has north neighbour 587 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1) THEN 588 nosws = ii_noso(nowe+1) ! west neighbour has north neighbour 589 END IF 590 END IF 591 592 IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists 593 IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN 594 noner = ii_noea(nono+1) ! north neighbour has east and west neighbours 595 nonwr = ii_nowe(nono+1) 596 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN 597 noner = ii_noea(nono+1) ! north neighbour has east neighbour 598 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN 599 nonwr = ii_nowe(nono+1) ! north neighbour has west neighbour 600 END IF 601 END IF 602 IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN ! south neighbour exists 603 IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN 604 noser = ii_noea(noso+1) ! south neighbour has east and west neighbours 605 noswr = ii_nowe(noso+1) 606 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN 607 noser = ii_noea(noso+1) ! south neighbour has east neighbour 608 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN 609 noswr = ii_nowe(noso+1) ! south neighbour has west neighbour 610 END IF 611 END IF 612 613 ! 614 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 615 ! 616 jpim1 = jpi-1 ! inner domain indices 617 jpjm1 = jpj-1 ! " " 618 jpkm1 = MAX( 1, jpk-1 ) ! " " 619 jpij = jpi*jpj ! jpi x j 620 DO jproc = 1, jpnij 621 ii = iin(jproc) 622 ij = ijn(jproc) 623 jpiall (jproc) = ijpi(ii,ij) 624 nis0all(jproc) = iis0(ii,ij) 625 nie0all(jproc) = iie0(ii,ij) 626 jpjall (jproc) = ijpj(ii,ij) 627 njs0all(jproc) = ijs0(ii,ij) 628 nje0all(jproc) = ije0(ii,ij) 629 ibonit(jproc) = ibondi(ii,ij) 630 ibonjt(jproc) = ibondj(ii,ij) 631 nimppt(jproc) = iimppt(ii,ij) 632 njmppt(jproc) = ijmppt(ii,ij) 633 END DO 634 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 ! 635 439 ! Save processor layout in ascii file 636 440 IF (llwrtlay) THEN 637 441 CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 638 WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo'//& 639 & ' ( local: narea jpi jpj )' 640 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 641 & ' ( local: ',narea,jpi,jpj,' )' 642 WRITE(inum,'(a)') 'narea jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 643 644 DO jproc = 1, jpnij 645 WRITE(inum,'(13i5,2i7)') jproc, jpiall(jproc), jpjall(jproc), & 646 & nis0all(jproc), njs0all(jproc), & 647 & nie0all(jproc), nje0all(jproc), & 648 & nimppt (jproc), njmppt (jproc), & 649 & ii_nono(jproc), ii_noso(jproc), & 650 & ii_nowe(jproc), ii_noea(jproc), & 651 & 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) 652 454 END DO 653 END IF 654 655 ! ! north fold parameter 656 ! Defined npolj, either 0, 3 , 4 , 5 , 6 657 ! In this case the important thing is that npolj /= 0 658 ! Because if we go through these line it is because jpni >1 and thus 659 ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0 660 npolj = 0 661 ij = ijn(narea) 662 IF( jperio == 3 .OR. jperio == 4 ) THEN 663 IF( ij == jpnj ) npolj = 3 664 ENDIF 665 IF( jperio == 5 .OR. jperio == 6 ) THEN 666 IF( ij == jpnj ) npolj = 5 667 ENDIF 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 668 491 ! 669 492 IF(lwp) THEN 670 493 WRITE(numout,*) 671 494 WRITE(numout,*) ' resulting internal parameters : ' 672 WRITE(numout,*) ' narea = ', narea 673 WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea 674 WRITE(numout,*) ' nono = ', nono , ' noso = ', noso 675 WRITE(numout,*) ' nbondi = ', nbondi 676 WRITE(numout,*) ' nbondj = ', nbondj 677 WRITE(numout,*) ' npolj = ', npolj 678 WRITE(numout,*) ' l_Iperio = ', l_Iperio 679 WRITE(numout,*) ' l_Jperio = ', l_Jperio 680 WRITE(numout,*) ' nimpp = ', nimpp 681 WRITE(numout,*) ' njmpp = ', njmpp 682 ENDIF 683 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 684 501 ! ! Prepare mpp north fold 685 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 686 507 CALL mpp_ini_north 687 508 IF (lwp) THEN 688 509 WRITE(numout,*) 689 510 WRITE(numout,*) ' ==>>> North fold boundary prepared for jpni >1' 690 ! additional prints in layout.dat 691 ENDIF 692 IF (llwrtlay) THEN 511 ENDIF 512 IF (llwrtlay) THEN ! additional prints in layout.dat 693 513 WRITE(inum,*) 694 514 WRITE(inum,*) 695 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 696 516 WRITE(inum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north 697 DO jp roc= 1, ndim_rank_north, 5698 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/) ) ) 699 519 END DO 700 520 ENDIF 701 ENDIF 702 703 ! 704 CALL mpp_ini_nc ! Initialize communicator for neighbourhood collective communications 705 ! 706 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 707 ! 708 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 709 CALL init_nfdcom ! northfold neighbour lists 710 IF (llwrtlay) THEN 711 WRITE(inum,*) 712 WRITE(inum,*) 713 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 714 WRITE(inum,*) 'nsndto : ', nsndto 715 WRITE(inum,*) 'isendto : ', isendto 716 ENDIF 717 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) 718 569 ! 719 570 IF (llwrtlay) CLOSE(inum) 720 571 ! 721 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 722 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 723 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 724 & iono, ioea, ioso, iowe, llisoce) 572 DEALLOCATE(iin, ijn, iimppt, ijmppt, ijpi, ijpj, ipproc, inei, llnei, impi, llisOce) 725 573 ! 726 574 END SUBROUTINE mpp_init … … 789 637 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 790 638 ENDIF 791 IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6) THEN639 IF( l_NFold ) THEN 792 640 ! minimize the size of the last row to compensate for the north pole folding coast 793 IF( jperio == 3 .OR. jperio == 4) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos794 IF( jperio == 5 .OR. jperio == 6) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos795 irm = knbj - irestj 796 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) 797 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 798 646 irestj = knbj - 1 - irm 799 647 klcj(:, irestj+1:knbj-1) = kjmax-1 … … 860 708 LOGICAL :: llist 861 709 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d ! max size of the subdomains along i,j 862 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llis oce ! - -710 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisOce ! - - 863 711 REAL(wp):: zpropland 864 712 !!---------------------------------------------------------------------- … … 883 731 iszimin = 4*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 884 732 iszjmin = 4*nn_hls 885 IF( jperio == 3 .OR. jperio == 4) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos886 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 887 735 ! 888 736 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 933 781 iszi1(ii) = iszi0(ji) 934 782 iszj1(ii) = iszj0(jj) 935 END 783 ENDIF 936 784 END DO 937 785 END DO … … 989 837 WRITE(numout,*) ' -----------------------------------------------------' 990 838 WRITE(numout,*) 991 END 839 ENDIF 992 840 ji = isz0 ! initialization with the largest value 993 ALLOCATE( llis oce(inbi0(ji), inbj0(ji)) )994 CALL mpp_is_ocean( llis oce ) ! Warning: must be call by all cores (call mpp_sum)995 inbijold = COUNT(llis oce)996 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 ) 997 845 DO ji =isz0-1,1,-1 998 ALLOCATE( llis oce(inbi0(ji), inbj0(ji)) )999 CALL mpp_is_ocean( llis oce ) ! Warning: must be call by all cores (call mpp_sum)1000 inbij = COUNT(llis oce)1001 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 ) 1002 850 IF(lwp .AND. inbij < inbijold) THEN 1003 851 WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & … … 1006 854 & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 1007 855 inbijold = inbij 1008 END 856 ENDIF 1009 857 END DO 1010 858 DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) … … 1022 870 DO WHILE( inbij > knbij ) ! while the number of ocean subdomains exceed the number of procs 1023 871 ii = ii -1 1024 ALLOCATE( llis oce(inbi0(ii), inbj0(ii)) )1025 CALL mpp_is_ocean( llis oce ) ! must be done by all core1026 inbij = COUNT(llis oce)1027 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 ) 1028 876 END DO 1029 877 knbi = inbi0(ii) … … 1073 921 ! 1074 922 ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip 1075 CALL read bot_strip( ijstr, ijsz, lloce )923 CALL read_mask( 1, ijstr, Ni0glo, ijsz, lloce ) 1076 924 inboce = COUNT(lloce) ! number of ocean point in the stripe 1077 925 DEALLOCATE(lloce) … … 1087 935 1088 936 1089 SUBROUTINE mpp_is_ocean( ld isoce )937 SUBROUTINE mpp_is_ocean( ldIsOce ) 1090 938 !!---------------------------------------------------------------------- 1091 939 !! *** ROUTINE mpp_is_ocean *** … … 1095 943 !! at least 1 ocean point. 1096 944 !! We must indeed ensure that each subdomain that is a neighbour 1097 !! of a land subdomain 945 !! of a land subdomain, has only land points on its boundary 1098 946 !! (inside the inner subdomain) with the land subdomain. 1099 947 !! This is needed to get the proper bondary conditions on … … 1102 950 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1103 951 !!---------------------------------------------------------------------- 1104 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 1105 953 ! 1106 954 INTEGER :: idiv, iimax, ijmax, iarea … … 1115 963 ! do nothing if there is no land-sea mask 1116 964 IF( numbot == -1 .AND. numbdy == -1 ) THEN 1117 ld isoce(:,:) = .TRUE.965 ldIsOce(:,:) = .TRUE. 1118 966 RETURN 1119 967 ENDIF 1120 968 ! 1121 inbi = SIZE( ld isoce, dim = 1 )1122 inbj = SIZE( ld isoce, dim = 2 )969 inbi = SIZE( ldIsOce, dim = 1 ) 970 inbj = SIZE( ldIsOce, dim = 2 ) 1123 971 ! 1124 972 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 … … 1143 991 inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction 1144 992 isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? 1145 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 1146 994 ! 1147 995 IF( iarea == 1 ) THEN ! the first line was not read 1148 IF( jperio == 2 .OR. jperio == 7 ) THEN! north-south periodocity1149 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 1150 998 ELSE 1151 999 lloce(2:inx-1, 1) = .FALSE. ! closed boundary … … 1153 1001 ENDIF 1154 1002 IF( iarea == inbj ) THEN ! the last line was not read 1155 IF( jperio == 2 .OR. jperio == 7 ) THEN! north-south periodocity1156 CALL read bot_strip( 1, 1, lloce(2:inx-1,iny) )! read the first line -> last line of lloce1157 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 1158 1006 lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) 1159 1007 DO ji = 3,inx-1 … … 1163 1011 lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 1164 1012 END DO 1165 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 1166 1014 lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) 1167 1015 lloce(inx -1,iny-1) = lloce(2 ,iny-1) … … 1174 1022 ENDIF 1175 1023 ! ! first and last column were not read 1176 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) THEN1024 IF( l_Iperio ) THEN 1177 1025 lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity 1178 1026 ELSE … … 1193 1041 CALL mpp_sum( 'mppini', inboce_1d ) 1194 1042 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1195 ld isoce(:,:) = inboce(:,:) /= 01043 ldIsOce(:,:) = inboce(:,:) /= 0 1196 1044 DEALLOCATE(inboce, inboce_1d) 1197 1045 ! … … 1199 1047 1200 1048 1201 SUBROUTINE read bot_strip( kjstr, kjcnt, ldoce )1202 !!---------------------------------------------------------------------- 1203 !! *** ROUTINE read bot_strip***1049 SUBROUTINE read_mask( kistr, kjstr, kicnt, kjcnt, ldoce ) 1050 !!---------------------------------------------------------------------- 1051 !! *** ROUTINE read_mask *** 1204 1052 !! 1205 1053 !! ** Purpose : Read relevant bathymetric information in order to … … 1209 1057 !! ** Method : read stipe of size (Ni0glo,...) 1210 1058 !!---------------------------------------------------------------------- 1211 INTEGER , INTENT(in ) :: kjstr ! startingj position of the reading1212 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read1213 LOGICAL, DIMENSION( Ni0glo,kjcnt), INTENT( out) :: ldoce! ldoce(i,j) = .true. if the point (i,j) is ocean1214 ! 1215 INTEGER :: inumsave! local logical unit1216 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 1217 1065 !!---------------------------------------------------------------------- 1218 1066 ! … … 1220 1068 ! 1221 1069 IF( numbot /= -1 ) THEN 1222 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/) ) 1223 1071 ELSE 1224 1072 zbot(:,:) = 1._wp ! put a non-null value … … 1226 1074 ! 1227 1075 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists 1228 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/) ) 1229 1077 zbot(:,:) = zbot(:,:) * zbdy(:,:) 1230 1078 ENDIF 1231 1079 ! 1232 ldoce(:,:) = zbot(:,:) > 0._wp1080 ldoce(:,:) = NINT(zbot(:,:)) > 0 1233 1081 numout = inumsave 1234 1082 ! 1235 END SUBROUTINE read bot_strip1236 1237 1238 SUBROUTINE mpp_getnum( ld isoce, kproc, kipos, kjpos )1083 END SUBROUTINE read_mask 1084 1085 1086 SUBROUTINE mpp_getnum( ldIsOce, kproc, kipos, kjpos ) 1239 1087 !!---------------------------------------------------------------------- 1240 1088 !! *** ROUTINE mpp_getnum *** … … 1244 1092 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1245 1093 !!---------------------------------------------------------------------- 1246 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ld isoce ! F if land process1247 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) 1248 1096 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1249 1097 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) … … 1253 1101 !!---------------------------------------------------------------------- 1254 1102 ! 1255 ini = SIZE(ld isoce, dim = 1)1256 inj = SIZE(ld isoce, dim = 2)1103 ini = SIZE(ldIsOce, dim = 1) 1104 inj = SIZE(ldIsOce, dim = 2) 1257 1105 inij = SIZE(kipos) 1258 1106 ! … … 1264 1112 ii = 1 + MOD(iarea0,ini) 1265 1113 ij = 1 + iarea0/ini 1266 IF( ld isoce(ii,ij) ) THEN1114 IF( ldIsOce(ii,ij) ) THEN 1267 1115 icont = icont + 1 1268 1116 kproc(ii,ij) = icont … … 1272 1120 END DO 1273 1121 ! if needed add some land subdomains to reach inij active subdomains 1274 i2add = inij - COUNT( ld isoce )1122 i2add = inij - COUNT( ldIsOce ) 1275 1123 DO jarea = 1, ini*inj 1276 1124 iarea0 = jarea - 1 1277 1125 ii = 1 + MOD(iarea0,ini) 1278 1126 ij = 1 + iarea0/ini 1279 IF( .NOT. ld isoce(ii,ij) .AND. i2add > 0 ) THEN1127 IF( .NOT. ldIsOce(ii,ij) .AND. i2add > 0 ) THEN 1280 1128 icont = icont + 1 1281 1129 kproc(ii,ij) = icont … … 1287 1135 ! 1288 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 1289 1226 1290 1227 … … 1343 1280 !!---------------------------------------------------------------------- 1344 1281 ! 1345 !initializes the north-fold communication variables 1346 isendto(:) = 0 1347 nsndto = 0 1348 ! 1349 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 1350 1292 ! 1351 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1352 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1353 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1354 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 1355 1295 ! 1356 ! loop over the other north-fold processes to find the processes 1357 ! 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 1358 1306 ! 1359 DO jn = 1, jpni 1360 ! 1361 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1362 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1363 ! 1364 IF ( sxT < sxM .AND. sxM < dxT ) THEN 1365 nsndto = nsndto + 1 1366 isendto(nsndto) = jn 1367 ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN 1368 nsndto = nsndto + 1 1369 isendto(nsndto) = jn 1370 ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN 1371 nsndto = nsndto + 1 1372 isendto(nsndto) = jn 1373 ENDIF 1374 ! 1375 END DO 1376 ! 1377 ENDIF 1378 l_north_nogather = .TRUE. 1307 END DO 1379 1308 ! 1380 1309 END SUBROUTINE init_nfdcom … … 1389 1318 !!---------------------------------------------------------------------- 1390 1319 ! 1391 Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2) 1392 Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2) 1393 ! 1394 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1395 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1396 ! 1397 IF( nn_hls == 1 ) THEN !* halo size of 1 1398 ! 1399 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0 1400 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0 1401 ! 1402 ELSE !* larger halo size... 1403 ! 1404 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1 1405 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1 1406 ! 1407 ENDIF 1320 Nis0 = 1+nn_hls 1321 Njs0 = 1+nn_hls 1322 Nie0 = jpi-nn_hls 1323 Nje0 = jpj-nn_hls 1408 1324 ! 1409 1325 Ni_0 = Nie0 - Nis0 + 1 1410 1326 Nj_0 = Nje0 - Njs0 + 1 1411 Ni_1 = Nie1 - Nis1 + 1 1412 Nj_1 = Nje1 - Njs1 + 1 1413 Ni_2 = Nie2 - Nis2 + 1 1414 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 ! " " 1415 1332 ! 1416 1333 END SUBROUTINE init_doloop
Note: See TracChangeset
for help on using the changeset viewer.