Changeset 13766 for NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC
- Timestamp:
- 2020-11-10T12:57:08+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_12905_xios_ancil
- Files:
-
- 13 edited
- 3 copied
-
. (modified) (1 prop)
-
src/OCE/LBC/halo_mng.F90 (copied) (copied from NEMO/trunk/src/OCE/LBC/halo_mng.F90)
-
src/OCE/LBC/lbc_lnk_multi_generic.h90 (modified) (3 diffs)
-
src/OCE/LBC/lbc_nfd_ext_generic.h90 (modified) (3 diffs)
-
src/OCE/LBC/lbc_nfd_generic.h90 (modified) (7 diffs)
-
src/OCE/LBC/lbc_nfd_nogather_generic.h90 (modified) (15 diffs)
-
src/OCE/LBC/lbclnk.F90 (modified) (10 diffs)
-
src/OCE/LBC/lbcnfd.F90 (modified) (7 diffs)
-
src/OCE/LBC/lib_mpp.F90 (modified) (34 diffs)
-
src/OCE/LBC/mpp_allreduce_generic.h90 (modified) (3 diffs)
-
src/OCE/LBC/mpp_lbc_north_icb_generic.h90 (copied) (copied from NEMO/trunk/src/OCE/LBC/mpp_lbc_north_icb_generic.h90)
-
src/OCE/LBC/mpp_lnk_generic.h90 (modified) (16 diffs)
-
src/OCE/LBC/mpp_lnk_icb_generic.h90 (copied) (copied from NEMO/trunk/src/OCE/LBC/mpp_lnk_icb_generic.h90)
-
src/OCE/LBC/mpp_loc_generic.h90 (modified) (2 diffs)
-
src/OCE/LBC/mpp_nfd_generic.h90 (modified) (7 diffs)
-
src/OCE/LBC/mppini.F90 (modified) (59 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_12905_xios_ancil
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev @HEADext/AGRIF5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 8 9 9 # SETTE 10 ^/utils/CI/sette@ HEADsette10 ^/utils/CI/sette@13559 sette
-
- Property svn:externals
-
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/lbc_lnk_multi_generic.h90
r11536 r13766 1 #if defined DIM_2d 2 # define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j) 3 # define PTR_TYPE TYPE(PTR_2D) 4 # define PTR_ptab pt2d 5 #endif 6 #if defined DIM_3d 7 # define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j,k) 8 # define PTR_TYPE TYPE(PTR_3D) 9 # define PTR_ptab pt3d 10 #endif 11 #if defined DIM_4d 12 # define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j,k,l) 13 # define PTR_TYPE TYPE(PTR_4D) 14 # define PTR_ptab pt4d 1 #if defined SINGLE_PRECISION 2 # if defined DIM_2d 3 # define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j) 4 # define PTR_TYPE TYPE(PTR_2D_sp) 5 # define PTR_ptab pt2d 6 # endif 7 # if defined DIM_3d 8 # define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j,k) 9 # define PTR_TYPE TYPE(PTR_3D_sp) 10 # define PTR_ptab pt3d 11 # endif 12 # if defined DIM_4d 13 # define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j,k,l) 14 # define PTR_TYPE TYPE(PTR_4D_sp) 15 # define PTR_ptab pt4d 16 # endif 17 # define PRECISION sp 18 #else 19 # if defined DIM_2d 20 # define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j) 21 # define PTR_TYPE TYPE(PTR_2D_dp) 22 # define PTR_ptab pt2d 23 # endif 24 # if defined DIM_3d 25 # define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j,k) 26 # define PTR_TYPE TYPE(PTR_3D_dp) 27 # define PTR_ptab pt3d 28 # endif 29 # if defined DIM_4d 30 # define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j,k,l) 31 # define PTR_TYPE TYPE(PTR_4D_dp) 32 # define PTR_ptab pt4d 33 # endif 34 # define PRECISION dp 15 35 #endif 16 36 17 SUBROUTINE ROUTINE_MULTI( cdname & 18 & , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4 & 19 & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 & 20 & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 & 21 & , kfillmode, pfillval, lsend, lrecv, ihlcom ) 37 SUBROUTINE ROUTINE_MULTI( cdname & 38 & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & 39 & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & 40 & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & 41 & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & 42 & , kfillmode, pfillval, lsend, lrecv ) 22 43 !!--------------------------------------------------------------------- 23 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 24 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 25 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , pt10 , pt11 26 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 27 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 28 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 29 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 30 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 31 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 32 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 33 INTEGER , OPTIONAL , INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated 44 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 45 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 46 ARRAY_TYPE(:,:,:,:) , OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , & 47 & pt10 , pt11 , pt12 , pt13 , pt14 , pt15 , pt16 48 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 49 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , cdna9, & 50 & cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, cdna16 51 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 52 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , psgn9, & 53 & psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, psgn16 54 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 55 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 56 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 34 57 !! 35 58 INTEGER :: kfld ! number of elements that will be attributed 36 PTR_TYPE , DIMENSION(1 1) :: ptab_ptr ! pointer array37 CHARACTER(len=1) , DIMENSION(1 1) :: cdna_ptr ! nature of ptab_ptr grid-points38 REAL(wp) , DIMENSION(1 1) :: psgn_ptr ! sign used across the north fold boundary59 PTR_TYPE , DIMENSION(16) :: ptab_ptr ! pointer array 60 CHARACTER(len=1) , DIMENSION(16) :: cdna_ptr ! nature of ptab_ptr grid-points 61 REAL(wp) , DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary 39 62 !!--------------------------------------------------------------------- 40 63 ! … … 55 78 IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 56 79 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 80 IF( PRESENT(psgn12) ) CALL ROUTINE_LOAD( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 81 IF( PRESENT(psgn13) ) CALL ROUTINE_LOAD( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 82 IF( PRESENT(psgn14) ) CALL ROUTINE_LOAD( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 83 IF( PRESENT(psgn15) ) CALL ROUTINE_LOAD( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 84 IF( PRESENT(psgn16) ) CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 57 85 ! 58 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom)86 CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 59 87 ! 60 88 END SUBROUTINE ROUTINE_MULTI … … 79 107 END SUBROUTINE ROUTINE_LOAD 80 108 109 #undef PRECISION 81 110 #undef ARRAY_TYPE 82 111 #undef PTR_TYPE -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/lbc_nfd_ext_generic.h90
r10525 r13766 8 8 # define L_SIZE(ptab) 1 9 9 #endif 10 #define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 10 #if defined SINGLE_PRECISION 11 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 12 # define PRECISION sp 13 #else 14 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 15 # define PRECISION dp 16 #endif 11 17 12 18 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj ) … … 28 34 ! 29 35 SELECT CASE ( jpni ) 30 CASE ( 1 ) ; ipj = nlcj! 1 proc only along the i-direction36 CASE ( 1 ) ; ipj = jpj ! 1 proc only along the i-direction 31 37 CASE DEFAULT ; ipj = 4 ! several proc along the i-direction 32 38 END SELECT … … 149 155 END SUBROUTINE ROUTINE_NFD 150 156 157 #undef PRECISION 151 158 #undef ARRAY_TYPE 152 159 #undef ARRAY_IN -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/lbc_nfd_generic.h90
r10425 r13766 4 4 # define F_SIZE(ptab) kfld 5 5 # if defined DIM_2d 6 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f) 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 7 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 12 # define J_SIZE(ptab) SIZE(ptab(1)%pt2d,2) 8 13 # define K_SIZE(ptab) 1 9 14 # define L_SIZE(ptab) 1 10 15 # endif 11 16 # if defined DIM_3d 12 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f) 17 # if defined SINGLE_PRECISION 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 19 # else 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 21 # endif 13 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 23 # define J_SIZE(ptab) SIZE(ptab(1)%pt3d,2) 14 24 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 15 25 # define L_SIZE(ptab) 1 16 26 # endif 17 27 # if defined DIM_4d 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f) 28 # if defined SINGLE_PRECISION 29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 30 # else 31 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 32 # endif 19 33 # 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) 20 35 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 21 36 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) … … 28 43 # if defined DIM_2d 29 44 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 45 # define J_SIZE(ptab) SIZE(ptab,2) 30 46 # define K_SIZE(ptab) 1 31 47 # define L_SIZE(ptab) 1 … … 33 49 # if defined DIM_3d 34 50 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) 51 # define J_SIZE(ptab) SIZE(ptab,2) 35 52 # define K_SIZE(ptab) SIZE(ptab,3) 36 53 # define L_SIZE(ptab) 1 … … 38 55 # if defined DIM_4d 39 56 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) 57 # define J_SIZE(ptab) SIZE(ptab,2) 40 58 # define K_SIZE(ptab) SIZE(ptab,3) 41 59 # define L_SIZE(ptab) SIZE(ptab,4) 42 60 # endif 43 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 61 # if defined SINGLE_PRECISION 62 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 63 # else 64 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 65 # endif 44 66 #endif 67 68 # if defined SINGLE_PRECISION 69 # define PRECISION sp 70 # else 71 # define PRECISION dp 72 # endif 45 73 46 74 #if defined MULTI … … 54 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 55 83 ! 56 INTEGER :: ji, jj, jk, jl, jh,jf ! dummy loop indices57 INTEGER :: ipi, ipj, ipk, ipl,ipf ! dimension of the input array58 INTEGER :: i jt, iju, ipjm184 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 85 INTEGER :: ipj, ipk, ipl, ipf ! dimension of the input array 86 INTEGER :: ii1, ii2, ij1, ij2 59 87 !!---------------------------------------------------------------------- 60 88 ! 61 ipk = K_SIZE(ptab) ! 3rd dimension 89 ipj = J_SIZE(ptab) ! 2nd dimension 90 ipk = K_SIZE(ptab) ! 3rd - 62 91 ipl = L_SIZE(ptab) ! 4th - 63 92 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 64 !65 !66 SELECT CASE ( jpni )67 CASE ( 1 ) ; ipj = nlcj ! 1 proc only along the i-direction68 CASE DEFAULT ; ipj = 4 ! several proc along the i-direction69 END SELECT70 ipjm1 = ipj-171 72 93 ! 73 94 DO jf = 1, ipf ! Loop on the number of arrays to be treated … … 79 100 SELECT CASE ( NAT_IN(jf) ) 80 101 CASE ( 'T' , 'W' ) ! T-, W-point 81 DO ji = 2, jpiglo 82 ijt = jpiglo-ji+2 83 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 84 END DO 85 ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-2,:,:,jf) 86 DO ji = jpiglo/2+1, jpiglo 87 ijt = jpiglo-ji+2 88 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) 89 END DO 102 DO jl = 1, ipl; DO jk = 1, ipk 103 ! 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 116 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 90 156 CASE ( 'U' ) ! U-point 91 DO ji = 1, jpiglo-1 92 iju = jpiglo-ji+1 93 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 94 END DO 95 ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-2,:,:,jf) 96 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-2,:,:,jf) 97 DO ji = jpiglo/2, jpiglo-1 98 iju = jpiglo-ji+1 99 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) 100 END DO 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 198 END DO 199 ! 200 END DO; END DO 101 201 CASE ( 'V' ) ! V-point 102 DO ji = 2, jpiglo 103 ijt = jpiglo-ji+2 104 ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 105 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-3,:,:,jf) 106 END DO 107 ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-3,:,:,jf) 202 DO jl = 1, ipl; DO jk = 1, ipk 203 ! 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 216 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 108 237 CASE ( 'F' ) ! F-point 109 DO ji = 1, jpiglo-1 110 iju = jpiglo-ji+1 111 ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 112 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-3,:,:,jf) 113 END DO 114 ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-3,:,:,jf) 115 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-3,:,:,jf) 116 END SELECT 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) 117 264 ! 118 265 CASE ( 5 , 6 ) ! * North fold F-point pivot … … 120 267 SELECT CASE ( NAT_IN(jf) ) 121 268 CASE ( 'T' , 'W' ) ! T-, W-point 122 DO ji = 1, jpiglo 123 ijt = jpiglo-ji+1 124 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-1,:,:,jf) 125 END DO 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 126 317 CASE ( 'U' ) ! U-point 127 DO ji = 1, jpiglo-1 128 iju = jpiglo-ji 129 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-1,:,:,jf) 130 END DO 131 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-1,:,:,jf) 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 132 353 CASE ( 'V' ) ! V-point 133 DO ji = 1, jpiglo 134 ijt = jpiglo-ji+1 135 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 136 END DO 137 DO ji = jpiglo/2+1, jpiglo 138 ijt = jpiglo-ji+1 139 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) 140 END DO 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 141 398 CASE ( 'F' ) ! F-point 142 DO ji = 1, jpiglo-1 143 iju = jpiglo-ji 144 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 145 END DO 146 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-2,:,:,jf) 147 DO ji = jpiglo/2+1, jpiglo-1 148 iju = jpiglo-ji 149 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) 150 END DO 151 END SELECT 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) 152 454 ! 153 CASE DEFAULT ! * closed : the code probably never go through 154 ! 155 SELECT CASE ( NAT_IN(jf) ) 156 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 157 ARRAY_IN(:, 1 ,:,:,jf) = 0._wp 158 ARRAY_IN(:,ipj,:,:,jf) = 0._wp 159 CASE ( 'F' ) ! F-point 160 ARRAY_IN(:,ipj,:,:,jf) = 0._wp 161 END SELECT 162 ! 163 END SELECT ! npolj 455 END SELECT ! npolj 164 456 ! 165 END DO 457 END DO ! ipf 166 458 ! 167 459 END SUBROUTINE ROUTINE_NFD 168 460 461 #undef PRECISION 169 462 #undef ARRAY_TYPE 170 463 #undef ARRAY_IN 171 464 #undef NAT_IN 172 465 #undef SGN_IN 466 #undef J_SIZE 173 467 #undef K_SIZE 174 468 #undef L_SIZE -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r11536 r13766 4 4 # define F_SIZE(ptab) kfld 5 5 # if defined DIM_2d 6 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f) 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 7 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 8 12 # define K_SIZE(ptab) 1 … … 10 14 # endif 11 15 # if defined DIM_3d 12 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f) 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 13 21 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 14 22 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 16 24 # endif 17 25 # if defined DIM_4d 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f) 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 19 31 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 20 32 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 21 33 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 22 34 # endif 23 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab2(f) 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 24 40 # define J_SIZE(ptab2) SIZE(ptab2(1)%pt4d,2) 25 41 # define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l) … … 44 60 # define L_SIZE(ptab) SIZE(ptab,4) 45 61 # endif 46 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l)47 62 # define J_SIZE(ptab2) SIZE(ptab2,2) 48 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 49 # define ARRAY2_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 50 #endif 51 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 52 77 SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld ) 53 78 !!---------------------------------------------------------------------- … … 57 82 !! 58 83 !!---------------------------------------------------------------------- 59 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied60 ARRAY2_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied84 ARRAY_TYPE(:,:,:,:,:) 85 ARRAY2_TYPE(:,:,:,:,:) 61 86 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 62 87 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 63 88 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 64 89 ! 65 INTEGER :: ji, jj, jk, 66 INTEGER :: ipi, ipj, ipk, ipl, ipf 67 INTEGER :: ijt, iju, ij pj, ijpjp1, ijta, ijua, jia, startloop, endloop90 INTEGER :: ji, jj, jk, jn, ii, jl, jh, jf ! dummy loop indices 91 INTEGER :: ipi, ipj, ipk, ipl, ipf, iij, ijj ! dimension of the input array 92 INTEGER :: ijt, iju, ijta, ijua, jia, startloop, endloop 68 93 LOGICAL :: l_fast_exchanges 69 94 !!---------------------------------------------------------------------- … … 75 100 ! Security check for further developments 76 101 IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 77 !78 ijpj = 1 ! index of first modified line79 ijpjp1 = 2 ! index + 180 81 102 ! 2nd dimension determines exchange speed 82 103 IF (ipj == 1 ) THEN … … 95 116 ! 96 117 CASE ( 'T' , 'W' ) ! T-, W-point 97 IF ( nimpp /= 1 ) THEN ; startloop = 1 98 ELSE ; startloop = 2 99 ENDIF 100 ! 101 DO jl = 1, ipl; DO jk = 1, ipk 102 DO ji = startloop, nlci 103 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 104 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 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 125 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 105 129 END DO 106 130 END DO; END DO 107 131 IF( nimpp == 1 ) THEN 108 132 DO jl = 1, ipl; DO jk = 1, ipk 109 ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf) 110 END DO; END DO 111 ENDIF 112 ! 113 IF ( .NOT. l_fast_exchanges ) THEN 114 IF( nimpp >= jpiglo/2+1 ) THEN 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 138 END DO 139 END DO; END DO 140 ENDIF 141 ! 142 IF ( .NOT. l_fast_exchanges ) THEN 143 IF( nimpp >= Ni0glo/2+2 ) THEN 115 144 startloop = 1 116 ELSEIF( nimpp+ nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1) THEN117 startloop = jpiglo/2+1 - nimpp + 1118 ELSE 119 startloop = nlci + 1120 ENDIF 121 IF( startloop <= nlci ) THEN145 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 122 151 DO jl = 1, ipl; DO jk = 1, ipk 123 DO ji = startloop, nlci124 ijt = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 4152 DO ji = startloop, jpi 153 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 125 154 jia = ji + nimpp - 1 126 155 ijta = jpiglo - jia + 2 127 156 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 128 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf)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) 129 158 ELSE 130 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)159 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 131 160 ENDIF 132 161 END DO … … 134 163 ENDIF 135 164 ENDIF 136 137 165 CASE ( 'U' ) ! U-point 138 IF( nimpp + nlci - 1 /= jpiglo ) THEN139 endloop = nlci166 IF( nimpp + jpi - 1 /= jpiglo ) THEN 167 endloop = jpi 140 168 ELSE 141 endloop = nlci - 1 142 ENDIF 143 DO jl = 1, ipl; DO jk = 1, ipk 144 DO ji = 1, endloop 145 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 146 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 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 147 178 END DO 148 179 END DO; END DO 149 180 IF (nimpp .eq. 1) THEN 150 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 151 ENDIF 152 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 153 ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 154 ENDIF 155 ! 156 IF ( .NOT. l_fast_exchanges ) THEN 157 IF( nimpp + nlci - 1 /= jpiglo ) THEN 158 endloop = nlci 159 ELSE 160 endloop = nlci - 1 161 ENDIF 162 IF( nimpp >= jpiglo/2 ) THEN 163 startloop = 1 164 ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 165 startloop = jpiglo/2 - nimpp + 1 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 166 207 ELSE 167 208 startloop = endloop + 1 … … 170 211 DO jl = 1, ipl; DO jk = 1, ipk 171 212 DO ji = startloop, endloop 172 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3173 jia = ji + nimpp - 1 174 ijua = jpiglo - jia + 1 213 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 214 jia = ji + nimpp - 1 215 ijua = jpiglo - jia + 1 175 216 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 176 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf)217 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl,jf) 177 218 ELSE 178 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)219 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 179 220 ENDIF 180 221 END DO … … 185 226 CASE ( 'V' ) ! V-point 186 227 IF( nimpp /= 1 ) THEN 187 startloop = 1 228 startloop = 1 188 229 ELSE 189 startloop = 2 190 ENDIF 191 IF ( .NOT. l_fast_exchanges ) THEN 192 DO jl = 1, ipl; DO jk = 1, ipk 193 DO ji = startloop, nlci 194 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 195 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 196 END DO 197 END DO; END DO 198 ENDIF 199 DO jl = 1, ipl; DO jk = 1, ipk 200 DO ji = startloop, nlci 201 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 202 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 230 startloop = 1 + nn_hls 231 ENDIF 232 IF ( .NOT. l_fast_exchanges ) THEN 233 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 241 END DO; END DO 242 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) 203 247 END DO 204 248 END DO; END DO 205 249 IF (nimpp .eq. 1) THEN 206 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf) 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 207 256 ENDIF 208 257 CASE ( 'F' ) ! F-point 209 IF( nimpp + nlci - 1 /= jpiglo ) THEN210 endloop = nlci258 IF( nimpp + jpi - 1 /= jpiglo ) THEN 259 endloop = jpi 211 260 ELSE 212 endloop = nlci - 1 213 ENDIF 214 IF ( .NOT. l_fast_exchanges ) THEN 215 DO jl = 1, ipl; DO jk = 1, ipk 216 DO ji = 1, endloop 217 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 218 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 219 END DO 261 endloop = jpi - nn_hls 262 ENDIF 263 IF ( .NOT. l_fast_exchanges ) THEN 264 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 220 272 END DO; END DO 221 273 ENDIF 222 274 DO jl = 1, ipl; DO jk = 1, ipk 223 275 DO ji = 1, endloop 224 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 225 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 226 END DO 227 END DO; END DO 228 IF (nimpp .eq. 1) THEN 229 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf) 230 IF ( .NOT. l_fast_exchanges ) & 231 ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 232 ENDIF 233 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 234 ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf) 235 IF ( .NOT. l_fast_exchanges ) & 236 ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 237 ENDIF 238 ! 239 END SELECT 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 240 308 ! 241 309 CASE ( 5, 6 ) ! * North fold F-point pivot … … 244 312 CASE ( 'T' , 'W' ) ! T-, W-point 245 313 DO jl = 1, ipl; DO jk = 1, ipk 246 DO ji = 1, nlci 247 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 248 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 249 END DO 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 250 321 END DO; END DO 251 322 ! 252 323 CASE ( 'U' ) ! U-point 253 IF( nimpp + nlci - 1 /= jpiglo ) THEN254 endloop = nlci324 IF( nimpp + jpi - 1 /= jpiglo ) THEN 325 endloop = jpi 255 326 ELSE 256 endloop = nlci - 1 257 ENDIF 258 DO jl = 1, ipl; DO jk = 1, ipk 259 DO ji = 1, endloop 260 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 261 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 262 END DO 263 END DO; END DO 264 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 265 DO jl = 1, ipl; DO jk = 1, ipk 266 ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf) 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 267 347 END DO; END DO 268 348 ENDIF … … 270 350 CASE ( 'V' ) ! V-point 271 351 DO jl = 1, ipl; DO jk = 1, ipk 272 DO ji = 1, nlci 273 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 274 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 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 275 358 END DO 276 359 END DO; END DO 277 360 278 361 IF ( .NOT. l_fast_exchanges ) THEN 279 IF( nimpp >= jpiglo/2+1) THEN362 IF( nimpp >= Ni0glo/2+2 ) THEN 280 363 startloop = 1 281 ELSEIF( nimpp+ nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1) THEN282 startloop = jpiglo/2+1 - nimpp + 1283 ELSE 284 startloop = nlci + 1285 ENDIF 286 IF( startloop <= nlci ) THEN287 DO jl = 1, ipl; DO jk = 1, ipk 288 DO ji = startloop, nlci289 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3290 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)291 END DO364 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 365 startloop = Ni0glo/2+2 - nimpp + nn_hls 366 ELSE 367 startloop = jpi + 1 368 ENDIF 369 IF( startloop <= jpi ) THEN 370 DO jl = 1, ipl; DO jk = 1, ipk 371 DO ji = startloop, jpi 372 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 373 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 374 END DO 292 375 END DO; END DO 293 376 ENDIF … … 295 378 ! 296 379 CASE ( 'F' ) ! F-point 297 IF( nimpp + nlci - 1 /= jpiglo ) THEN298 endloop = nlci380 IF( nimpp + jpi - 1 /= jpiglo ) THEN 381 endloop = jpi 299 382 ELSE 300 endloop = nlci - 1 301 ENDIF 302 DO jl = 1, ipl; DO jk = 1, ipk 303 DO ji = 1, endloop 304 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 305 ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 306 END DO 307 END DO; END DO 308 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 309 DO jl = 1, ipl; DO jk = 1, ipk 310 ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf) 311 END DO; END DO 312 ENDIF 313 ! 314 IF ( .NOT. l_fast_exchanges ) THEN 315 IF( nimpp + nlci - 1 /= jpiglo ) THEN 316 endloop = nlci 317 ELSE 318 endloop = nlci - 1 319 ENDIF 320 IF( nimpp >= jpiglo/2+1 ) THEN 321 startloop = 1 322 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 323 startloop = jpiglo/2+1 - nimpp + 1 383 endloop = jpi - nn_hls 384 ENDIF 385 DO jl = 1, ipl; DO jk = 1, ipk 386 DO jj = 1, nn_hls 387 ijj = jpj -jj +1 388 DO ji = 1, endloop 389 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 390 ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 391 END DO 392 END DO 393 END DO; END DO 394 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 395 DO jl = 1, ipl; DO jk = 1, ipk 396 DO jj = 1, nn_hls 397 ijj = jpj -jj +1 398 DO ii = 1, nn_hls 399 iij = jpi -ii+1 400 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 DO 402 END DO 403 END DO; END DO 404 ENDIF 405 ! 406 IF ( .NOT. l_fast_exchanges ) THEN 407 IF( nimpp + jpi - 1 /= jpiglo ) THEN 408 endloop = jpi 409 ELSE 410 endloop = jpi - nn_hls 411 ENDIF 412 IF( nimpp >= Ni0glo/2+2 ) THEN 413 startloop = 1 414 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 415 startloop = Ni0glo/2+2 - nimpp + nn_hls 324 416 ELSE 325 417 startloop = endloop + 1 … … 328 420 DO jl = 1, ipl; DO jk = 1, ipk 329 421 DO ji = startloop, endloop 330 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 2331 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)422 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 423 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 332 424 END DO 333 425 END DO; END DO … … 345 437 END DO ! End jf loop 346 438 END SUBROUTINE ROUTINE_NFD 439 #undef PRECISION 347 440 #undef ARRAY_TYPE 348 441 #undef ARRAY_IN -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/lbclnk.F90
r12377 r13766 28 28 29 29 INTERFACE lbc_lnk 30 MODULE PROCEDURE mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 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 31 32 END INTERFACE 32 33 INTERFACE lbc_lnk_ptr 33 MODULE PROCEDURE mpp_lnk_2d_ptr , mpp_lnk_3d_ptr , mpp_lnk_4d_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 34 36 END INTERFACE 35 37 INTERFACE lbc_lnk_multi 36 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_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 37 40 END INTERFACE 38 41 ! 39 42 INTERFACE lbc_lnk_icb 40 MODULE PROCEDURE mpp_lnk_2d_icb 43 MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp 41 44 END INTERFACE 42 45 43 46 INTERFACE mpp_nfd 44 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 45 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 47 MODULE PROCEDURE mpp_nfd_2d_sp , mpp_nfd_3d_sp , mpp_nfd_4d_sp 48 MODULE PROCEDURE mpp_nfd_2d_dp , mpp_nfd_3d_dp , mpp_nfd_4d_dp 49 MODULE PROCEDURE mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp 50 MODULE PROCEDURE mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp 51 46 52 END INTERFACE 47 53 … … 92 98 !!---------------------------------------------------------------------- 93 99 94 # define DIM_2d 95 # define ROUTINE_LOAD load_ptr_2d 96 # define ROUTINE_MULTI lbc_lnk_2d_multi 97 # include "lbc_lnk_multi_generic.h90" 98 # undef ROUTINE_MULTI 99 # undef ROUTINE_LOAD 100 # undef DIM_2d 101 102 # define DIM_3d 103 # define ROUTINE_LOAD load_ptr_3d 104 # define ROUTINE_MULTI lbc_lnk_3d_multi 105 # include "lbc_lnk_multi_generic.h90" 106 # undef ROUTINE_MULTI 107 # undef ROUTINE_LOAD 108 # undef DIM_3d 109 110 # define DIM_4d 111 # define ROUTINE_LOAD load_ptr_4d 112 # define ROUTINE_MULTI lbc_lnk_4d_multi 100 !! 101 !! ---- SINGLE PRECISION VERSIONS 102 !! 103 # define SINGLE_PRECISION 104 # define DIM_2d 105 # define ROUTINE_LOAD load_ptr_2d_sp 106 # define ROUTINE_MULTI lbc_lnk_2d_multi_sp 107 # include "lbc_lnk_multi_generic.h90" 108 # undef ROUTINE_MULTI 109 # undef ROUTINE_LOAD 110 # undef DIM_2d 111 112 # define DIM_3d 113 # define ROUTINE_LOAD load_ptr_3d_sp 114 # define ROUTINE_MULTI lbc_lnk_3d_multi_sp 115 # include "lbc_lnk_multi_generic.h90" 116 # undef ROUTINE_MULTI 117 # undef ROUTINE_LOAD 118 # undef DIM_3d 119 120 # define DIM_4d 121 # define ROUTINE_LOAD load_ptr_4d_sp 122 # define ROUTINE_MULTI lbc_lnk_4d_multi_sp 123 # include "lbc_lnk_multi_generic.h90" 124 # undef ROUTINE_MULTI 125 # undef ROUTINE_LOAD 126 # undef DIM_4d 127 # undef SINGLE_PRECISION 128 !! 129 !! ---- DOUBLE PRECISION VERSIONS 130 !! 131 132 # define DIM_2d 133 # define ROUTINE_LOAD load_ptr_2d_dp 134 # define ROUTINE_MULTI lbc_lnk_2d_multi_dp 135 # include "lbc_lnk_multi_generic.h90" 136 # undef ROUTINE_MULTI 137 # undef ROUTINE_LOAD 138 # undef DIM_2d 139 140 # define DIM_3d 141 # define ROUTINE_LOAD load_ptr_3d_dp 142 # define ROUTINE_MULTI lbc_lnk_3d_multi_dp 143 # include "lbc_lnk_multi_generic.h90" 144 # undef ROUTINE_MULTI 145 # undef ROUTINE_LOAD 146 # undef DIM_3d 147 148 # define DIM_4d 149 # define ROUTINE_LOAD load_ptr_4d_dp 150 # define ROUTINE_MULTI lbc_lnk_4d_multi_dp 113 151 # include "lbc_lnk_multi_generic.h90" 114 152 # undef ROUTINE_MULTI … … 130 168 ! !== 2D array and array of 2D pointer ==! 131 169 ! 132 # define DIM_2d 133 # define ROUTINE_LNK mpp_lnk_2d 134 # include "mpp_lnk_generic.h90" 135 # undef ROUTINE_LNK 136 # define MULTI 137 # define ROUTINE_LNK mpp_lnk_2d_ptr 170 !! 171 !! ---- SINGLE PRECISION VERSIONS 172 !! 173 # define SINGLE_PRECISION 174 # define DIM_2d 175 # define ROUTINE_LNK mpp_lnk_2d_sp 176 # include "mpp_lnk_generic.h90" 177 # undef ROUTINE_LNK 178 # define MULTI 179 # define ROUTINE_LNK mpp_lnk_2d_ptr_sp 138 180 # include "mpp_lnk_generic.h90" 139 181 # undef ROUTINE_LNK … … 144 186 ! 145 187 # define DIM_3d 146 # define ROUTINE_LNK mpp_lnk_3d 147 # include "mpp_lnk_generic.h90" 148 # undef ROUTINE_LNK 149 # define MULTI 150 # define ROUTINE_LNK mpp_lnk_3d_ptr 188 # define ROUTINE_LNK mpp_lnk_3d_sp 189 # include "mpp_lnk_generic.h90" 190 # undef ROUTINE_LNK 191 # define MULTI 192 # define ROUTINE_LNK mpp_lnk_3d_ptr_sp 151 193 # include "mpp_lnk_generic.h90" 152 194 # undef ROUTINE_LNK … … 157 199 ! 158 200 # define DIM_4d 159 # define ROUTINE_LNK mpp_lnk_4d 160 # include "mpp_lnk_generic.h90" 161 # undef ROUTINE_LNK 162 # define MULTI 163 # define ROUTINE_LNK mpp_lnk_4d_ptr 164 # include "mpp_lnk_generic.h90" 165 # undef ROUTINE_LNK 166 # undef MULTI 167 # undef DIM_4d 201 # define ROUTINE_LNK mpp_lnk_4d_sp 202 # include "mpp_lnk_generic.h90" 203 # undef ROUTINE_LNK 204 # define MULTI 205 # define ROUTINE_LNK mpp_lnk_4d_ptr_sp 206 # include "mpp_lnk_generic.h90" 207 # undef ROUTINE_LNK 208 # undef MULTI 209 # undef DIM_4d 210 # undef SINGLE_PRECISION 211 212 !! 213 !! ---- DOUBLE PRECISION VERSIONS 214 !! 215 # define DIM_2d 216 # define ROUTINE_LNK mpp_lnk_2d_dp 217 # include "mpp_lnk_generic.h90" 218 # undef ROUTINE_LNK 219 # define MULTI 220 # define ROUTINE_LNK mpp_lnk_2d_ptr_dp 221 # include "mpp_lnk_generic.h90" 222 # undef ROUTINE_LNK 223 # undef MULTI 224 # undef DIM_2d 225 ! 226 ! !== 3D array and array of 3D pointer ==! 227 ! 228 # define DIM_3d 229 # define ROUTINE_LNK mpp_lnk_3d_dp 230 # include "mpp_lnk_generic.h90" 231 # undef ROUTINE_LNK 232 # define MULTI 233 # define ROUTINE_LNK mpp_lnk_3d_ptr_dp 234 # include "mpp_lnk_generic.h90" 235 # undef ROUTINE_LNK 236 # undef MULTI 237 # undef DIM_3d 238 ! 239 ! !== 4D array and array of 4D pointer ==! 240 ! 241 # define DIM_4d 242 # define ROUTINE_LNK mpp_lnk_4d_dp 243 # include "mpp_lnk_generic.h90" 244 # undef ROUTINE_LNK 245 # define MULTI 246 # define ROUTINE_LNK mpp_lnk_4d_ptr_dp 247 # include "mpp_lnk_generic.h90" 248 # undef ROUTINE_LNK 249 # undef MULTI 250 # undef DIM_4d 251 168 252 169 253 !!---------------------------------------------------------------------- … … 181 265 ! !== 2D array and array of 2D pointer ==! 182 266 ! 183 # define DIM_2d 184 # define ROUTINE_NFD mpp_nfd_2d 185 # include "mpp_nfd_generic.h90" 186 # undef ROUTINE_NFD 187 # define MULTI 188 # define ROUTINE_NFD mpp_nfd_2d_ptr 267 !! 268 !! ---- SINGLE PRECISION VERSIONS 269 !! 270 # define SINGLE_PRECISION 271 # define DIM_2d 272 # define ROUTINE_NFD mpp_nfd_2d_sp 273 # include "mpp_nfd_generic.h90" 274 # undef ROUTINE_NFD 275 # define MULTI 276 # define ROUTINE_NFD mpp_nfd_2d_ptr_sp 189 277 # include "mpp_nfd_generic.h90" 190 278 # undef ROUTINE_NFD … … 195 283 ! 196 284 # define DIM_3d 197 # define ROUTINE_NFD mpp_nfd_3d 198 # include "mpp_nfd_generic.h90" 199 # undef ROUTINE_NFD 200 # define MULTI 201 # define ROUTINE_NFD mpp_nfd_3d_ptr 285 # define ROUTINE_NFD mpp_nfd_3d_sp 286 # include "mpp_nfd_generic.h90" 287 # undef ROUTINE_NFD 288 # define MULTI 289 # define ROUTINE_NFD mpp_nfd_3d_ptr_sp 202 290 # include "mpp_nfd_generic.h90" 203 291 # undef ROUTINE_NFD … … 208 296 ! 209 297 # define DIM_4d 210 # define ROUTINE_NFD mpp_nfd_4d 211 # include "mpp_nfd_generic.h90" 212 # undef ROUTINE_NFD 213 # define MULTI 214 # define ROUTINE_NFD mpp_nfd_4d_ptr 215 # include "mpp_nfd_generic.h90" 216 # undef ROUTINE_NFD 217 # undef MULTI 218 # undef DIM_4d 219 298 # define ROUTINE_NFD mpp_nfd_4d_sp 299 # include "mpp_nfd_generic.h90" 300 # undef ROUTINE_NFD 301 # define MULTI 302 # define ROUTINE_NFD mpp_nfd_4d_ptr_sp 303 # include "mpp_nfd_generic.h90" 304 # undef ROUTINE_NFD 305 # undef MULTI 306 # undef DIM_4d 307 # undef SINGLE_PRECISION 308 309 !! 310 !! ---- DOUBLE PRECISION VERSIONS 311 !! 312 # define DIM_2d 313 # define ROUTINE_NFD mpp_nfd_2d_dp 314 # include "mpp_nfd_generic.h90" 315 # undef ROUTINE_NFD 316 # define MULTI 317 # define ROUTINE_NFD mpp_nfd_2d_ptr_dp 318 # include "mpp_nfd_generic.h90" 319 # undef ROUTINE_NFD 320 # undef MULTI 321 # undef DIM_2d 322 ! 323 ! !== 3D array and array of 3D pointer ==! 324 ! 325 # define DIM_3d 326 # define ROUTINE_NFD mpp_nfd_3d_dp 327 # include "mpp_nfd_generic.h90" 328 # undef ROUTINE_NFD 329 # define MULTI 330 # define ROUTINE_NFD mpp_nfd_3d_ptr_dp 331 # include "mpp_nfd_generic.h90" 332 # undef ROUTINE_NFD 333 # undef MULTI 334 # undef DIM_3d 335 ! 336 ! !== 4D array and array of 4D pointer ==! 337 ! 338 # define DIM_4d 339 # define ROUTINE_NFD mpp_nfd_4d_dp 340 # include "mpp_nfd_generic.h90" 341 # undef ROUTINE_NFD 342 # define MULTI 343 # define ROUTINE_NFD mpp_nfd_4d_ptr_dp 344 # include "mpp_nfd_generic.h90" 345 # undef ROUTINE_NFD 346 # undef MULTI 347 # undef DIM_4d 220 348 221 349 !!====================================================================== 222 350 223 351 224 225 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 226 !!--------------------------------------------------------------------- 352 !!====================================================================== 353 !!--------------------------------------------------------------------- 227 354 !! *** routine mpp_lbc_north_icb *** 228 355 !! … … 240 367 !! 241 368 !!---------------------------------------------------------------------- 242 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 243 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 244 ! ! = T , U , V , F or W -points 245 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 246 !! ! north fold, = 1. otherwise 247 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold 248 ! 249 INTEGER :: ji, jj, jr 250 INTEGER :: ierr, itaille, ildi, ilei, iilb 251 INTEGER :: ipj, ij, iproc 252 ! 253 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 254 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 255 !!---------------------------------------------------------------------- 256 #if defined key_mpp_mpi 257 ! 258 ipj=4 259 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & 260 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & 261 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) ) 262 ! 263 ztab_e(:,:) = 0._wp 264 znorthloc_e(:,:) = 0._wp 265 ! 266 ij = 1 - kextj 267 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e 268 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 269 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 270 ij = ij + 1 271 END DO 272 ! 273 itaille = jpimax * ( ipj + 2*kextj ) 274 ! 275 IF( ln_timing ) CALL tic_tac(.TRUE.) 276 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, & 277 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, & 278 & ncomm_north, ierr ) 279 ! 280 IF( ln_timing ) CALL tic_tac(.FALSE.) 281 ! 282 DO jr = 1, ndim_rank_north ! recover the global north array 283 iproc = nrank_north(jr) + 1 284 ildi = nldit (iproc) 285 ilei = nleit (iproc) 286 iilb = nimppt(iproc) 287 DO jj = 1-kextj, ipj+kextj 288 DO ji = ildi, ilei 289 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 290 END DO 291 END DO 292 END DO 293 294 ! 2. North-Fold boundary conditions 295 ! ---------------------------------- 296 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 297 298 ij = 1 - kextj 299 !! Scatter back to pt2d 300 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 301 DO ji= 1, jpi 302 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 303 END DO 304 ij = ij +1 305 END DO 306 ! 307 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 308 ! 309 #endif 310 END SUBROUTINE mpp_lbc_north_icb 311 312 313 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 369 # define SINGLE_PRECISION 370 # define ROUTINE_LNK mpp_lbc_north_icb_sp 371 # include "mpp_lbc_north_icb_generic.h90" 372 # undef ROUTINE_LNK 373 # undef SINGLE_PRECISION 374 # define ROUTINE_LNK mpp_lbc_north_icb_dp 375 # include "mpp_lbc_north_icb_generic.h90" 376 # undef ROUTINE_LNK 377 378 314 379 !!---------------------------------------------------------------------- 315 380 !! *** routine mpp_lnk_2d_icb *** … … 333 398 !! nono : number for local neighboring processors 334 399 !!---------------------------------------------------------------------- 335 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 336 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 337 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 338 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 339 INTEGER , INTENT(in ) :: kexti ! extra i-halo width 340 INTEGER , INTENT(in ) :: kextj ! extra j-halo width 341 ! 342 INTEGER :: jl ! dummy loop indices 343 INTEGER :: imigr, iihom, ijhom ! local integers 344 INTEGER :: ipreci, iprecj ! - - 345 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 346 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 347 !! 348 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn 349 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew 350 !!---------------------------------------------------------------------- 351 352 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area 353 iprecj = nn_hls + kextj 354 355 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 356 357 ! 1. standard boundary treatment 358 ! ------------------------------ 359 ! Order matters Here !!!! 360 ! 361 ! ! East-West boundaries 362 ! !* Cyclic east-west 363 IF( l_Iperio ) THEN 364 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east 365 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west 366 ! 367 ELSE !* closed 368 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point 369 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west 370 ENDIF 371 ! ! North-South boundaries 372 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 373 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north 374 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south 375 ELSE !* closed 376 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point 377 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south 378 ENDIF 379 ! 380 381 ! north fold treatment 382 ! ----------------------- 383 IF( npolj /= 0 ) THEN 384 ! 385 SELECT CASE ( jpni ) 386 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 387 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 388 END SELECT 389 ! 390 ENDIF 391 392 ! 2. East and west directions exchange 393 ! ------------------------------------ 394 ! we play with the neigbours AND the row number because of the periodicity 395 ! 396 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 397 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 398 iihom = jpi-nreci-kexti 399 DO jl = 1, ipreci 400 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 401 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 402 END DO 403 END SELECT 404 ! 405 ! ! Migrations 406 imigr = ipreci * ( jpj + 2*kextj ) 407 ! 408 IF( ln_timing ) CALL tic_tac(.TRUE.) 409 ! 410 SELECT CASE ( nbondi ) 411 CASE ( -1 ) 412 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 413 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 414 CALL mpi_wait(ml_req1,ml_stat,ml_err) 415 CASE ( 0 ) 416 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 417 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 418 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 419 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 420 CALL mpi_wait(ml_req1,ml_stat,ml_err) 421 CALL mpi_wait(ml_req2,ml_stat,ml_err) 422 CASE ( 1 ) 423 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 424 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 425 CALL mpi_wait(ml_req1,ml_stat,ml_err) 426 END SELECT 427 ! 428 IF( ln_timing ) CALL tic_tac(.FALSE.) 429 ! 430 ! ! Write Dirichlet lateral conditions 431 iihom = jpi - nn_hls 432 ! 433 SELECT CASE ( nbondi ) 434 CASE ( -1 ) 435 DO jl = 1, ipreci 436 pt2d(iihom+jl,:) = r2dew(:,jl,2) 437 END DO 438 CASE ( 0 ) 439 DO jl = 1, ipreci 440 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 441 pt2d(iihom+jl,:) = r2dew(:,jl,2) 442 END DO 443 CASE ( 1 ) 444 DO jl = 1, ipreci 445 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 446 END DO 447 END SELECT 448 449 450 ! 3. North and south directions 451 ! ----------------------------- 452 ! always closed : we play only with the neigbours 453 ! 454 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 455 ijhom = jpj-nrecj-kextj 456 DO jl = 1, iprecj 457 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 458 r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 459 END DO 460 ENDIF 461 ! 462 ! ! Migrations 463 imigr = iprecj * ( jpi + 2*kexti ) 464 ! 465 IF( ln_timing ) CALL tic_tac(.TRUE.) 466 ! 467 SELECT CASE ( nbondj ) 468 CASE ( -1 ) 469 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 470 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 471 CALL mpi_wait(ml_req1,ml_stat,ml_err) 472 CASE ( 0 ) 473 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 474 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 475 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 476 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 477 CALL mpi_wait(ml_req1,ml_stat,ml_err) 478 CALL mpi_wait(ml_req2,ml_stat,ml_err) 479 CASE ( 1 ) 480 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 481 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 482 CALL mpi_wait(ml_req1,ml_stat,ml_err) 483 END SELECT 484 ! 485 IF( ln_timing ) CALL tic_tac(.FALSE.) 486 ! 487 ! ! Write Dirichlet lateral conditions 488 ijhom = jpj - nn_hls 489 ! 490 SELECT CASE ( nbondj ) 491 CASE ( -1 ) 492 DO jl = 1, iprecj 493 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 494 END DO 495 CASE ( 0 ) 496 DO jl = 1, iprecj 497 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 498 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 499 END DO 500 CASE ( 1 ) 501 DO jl = 1, iprecj 502 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 503 END DO 504 END SELECT 505 ! 506 END SUBROUTINE mpp_lnk_2d_icb 507 400 401 # define SINGLE_PRECISION 402 # define ROUTINE_LNK mpp_lnk_2d_icb_sp 403 # include "mpp_lnk_icb_generic.h90" 404 # undef ROUTINE_LNK 405 # undef SINGLE_PRECISION 406 # define ROUTINE_LNK mpp_lnk_2d_icb_dp 407 # include "mpp_lnk_icb_generic.h90" 408 # undef ROUTINE_LNK 409 508 410 END MODULE lbclnk 509 411 -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/lbcnfd.F90
r11536 r13766 26 26 27 27 INTERFACE lbc_nfd 28 MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d 29 MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 30 MODULE PROCEDURE lbc_nfd_2d_ext 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 31 34 END INTERFACE 32 35 ! 33 36 INTERFACE lbc_nfd_nogather 34 37 ! ! Currently only 4d array version is needed 35 MODULE PROCEDURE lbc_nfd_nogather_2d , lbc_nfd_nogather_3d 36 MODULE PROCEDURE lbc_nfd_nogather_4d 37 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 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 38 44 ! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr 39 45 END INTERFACE 40 46 41 TYPE, PUBLIC :: PTR_2D !: array of 2D pointers (also used in lib_mpp) 42 REAL(wp), DIMENSION (:,:) , POINTER :: pt2d 43 END TYPE PTR_2D 44 TYPE, PUBLIC :: PTR_3D !: array of 3D pointers (also used in lib_mpp) 45 REAL(wp), DIMENSION (:,:,:) , POINTER :: pt3d 46 END TYPE PTR_3D 47 TYPE, PUBLIC :: PTR_4D !: array of 4D pointers (also used in lib_mpp) 48 REAL(wp), DIMENSION (:,:,:,:), POINTER :: pt4d 49 END TYPE PTR_4D 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 56 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 50 67 51 68 PUBLIC lbc_nfd ! north fold conditions … … 53 70 54 71 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !: 55 INTEGER, PUBLIC :: nsndto , nfsloop, nfeloop!:72 INTEGER, PUBLIC :: nsndto !: 56 73 INTEGER, PUBLIC, DIMENSION (jpmaxngh) :: isendto !: processes to which communicate 74 INTEGER, PUBLIC :: ijpj 57 75 58 76 !!---------------------------------------------------------------------- … … 75 93 !!---------------------------------------------------------------------- 76 94 ! 77 ! !== 2D array and array of 2D pointer ==! 78 ! 79 # define DIM_2d 80 # define ROUTINE_NFD lbc_nfd_2d 81 # include "lbc_nfd_generic.h90" 82 # undef ROUTINE_NFD 83 # define MULTI 84 # define ROUTINE_NFD lbc_nfd_2d_ptr 95 ! !== SINGLE PRECISION VERSIONS 96 ! 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 85 107 # include "lbc_nfd_generic.h90" 86 108 # undef ROUTINE_NFD … … 91 113 ! 92 114 # define DIM_2d 93 # define ROUTINE_NFD lbc_nfd_2d_ext 115 # define ROUTINE_NFD lbc_nfd_2d_ext_sp 94 116 # include "lbc_nfd_ext_generic.h90" 95 117 # undef ROUTINE_NFD … … 99 121 ! 100 122 # define DIM_3d 101 # define ROUTINE_NFD lbc_nfd_3d 102 # include "lbc_nfd_generic.h90" 103 # undef ROUTINE_NFD 104 # define MULTI 105 # define ROUTINE_NFD lbc_nfd_3d_ptr 106 # include "lbc_nfd_generic.h90" 107 # undef ROUTINE_NFD 108 # undef MULTI 109 # undef DIM_3d 110 ! 111 ! !== 4D array and array of 4D pointer ==! 112 ! 113 # define DIM_4d 114 # define ROUTINE_NFD lbc_nfd_4d 115 # include "lbc_nfd_generic.h90" 116 # undef ROUTINE_NFD 117 # define MULTI 118 # define ROUTINE_NFD lbc_nfd_4d_ptr 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 119 141 # include "lbc_nfd_generic.h90" 120 142 # undef ROUTINE_NFD … … 127 149 ! 128 150 # define DIM_2d 129 # define ROUTINE_NFD lbc_nfd_nogather_2d 130 # include "lbc_nfd_nogather_generic.h90" 131 # undef ROUTINE_NFD 132 # define MULTI 133 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr 134 # include "lbc_nfd_nogather_generic.h90" 135 # undef ROUTINE_NFD 136 # undef MULTI 137 # undef DIM_2d 138 ! 139 ! !== 3D array and array of 3D pointer ==! 140 ! 141 # define DIM_3d 142 # define ROUTINE_NFD lbc_nfd_nogather_3d 143 # include "lbc_nfd_nogather_generic.h90" 144 # undef ROUTINE_NFD 145 # define MULTI 146 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr 147 # include "lbc_nfd_nogather_generic.h90" 148 # undef ROUTINE_NFD 149 # undef MULTI 150 # undef DIM_3d 151 ! 152 ! !== 4D array and array of 4D pointer ==! 153 ! 154 # define DIM_4d 155 # define ROUTINE_NFD lbc_nfd_nogather_4d 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 156 178 # include "lbc_nfd_nogather_generic.h90" 157 179 # undef ROUTINE_NFD … … 162 184 !# undef MULTI 163 185 # undef DIM_4d 164 165 !!---------------------------------------------------------------------- 186 # undef SINGLE_PRECISION 187 188 !!---------------------------------------------------------------------- 189 ! 190 ! !== DOUBLE PRECISION VERSIONS 191 ! 192 ! 193 ! !== 2D array and array of 2D pointer ==! 194 ! 195 # define DIM_2d 196 # define ROUTINE_NFD lbc_nfd_2d_dp 197 # include "lbc_nfd_generic.h90" 198 # undef ROUTINE_NFD 199 # define MULTI 200 # define ROUTINE_NFD lbc_nfd_2d_ptr_dp 201 # include "lbc_nfd_generic.h90" 202 # undef ROUTINE_NFD 203 # undef MULTI 204 # undef DIM_2d 205 ! 206 ! !== 2D array with extra haloes ==! 207 ! 208 # define DIM_2d 209 # define ROUTINE_NFD lbc_nfd_2d_ext_dp 210 # include "lbc_nfd_ext_generic.h90" 211 # undef ROUTINE_NFD 212 # undef DIM_2d 213 ! 214 ! !== 3D array and array of 3D pointer ==! 215 ! 216 # define DIM_3d 217 # define ROUTINE_NFD lbc_nfd_3d_dp 218 # include "lbc_nfd_generic.h90" 219 # undef ROUTINE_NFD 220 # define MULTI 221 # define ROUTINE_NFD lbc_nfd_3d_ptr_dp 222 # include "lbc_nfd_generic.h90" 223 # undef ROUTINE_NFD 224 # undef MULTI 225 # undef DIM_3d 226 ! 227 ! !== 4D array and array of 4D pointer ==! 228 ! 229 # define DIM_4d 230 # define ROUTINE_NFD lbc_nfd_4d_dp 231 # include "lbc_nfd_generic.h90" 232 # undef ROUTINE_NFD 233 # define MULTI 234 # define ROUTINE_NFD lbc_nfd_4d_ptr_dp 235 # include "lbc_nfd_generic.h90" 236 # undef ROUTINE_NFD 237 # undef MULTI 238 # undef DIM_4d 239 ! 240 ! lbc_nfd_nogather routines 241 ! 242 ! !== 2D array and array of 2D pointer ==! 243 ! 244 # define DIM_2d 245 # define ROUTINE_NFD lbc_nfd_nogather_2d_dp 246 # include "lbc_nfd_nogather_generic.h90" 247 # undef ROUTINE_NFD 248 # define MULTI 249 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_dp 250 # include "lbc_nfd_nogather_generic.h90" 251 # undef ROUTINE_NFD 252 # undef MULTI 253 # undef DIM_2d 254 ! 255 ! !== 3D array and array of 3D pointer ==! 256 ! 257 # define DIM_3d 258 # define ROUTINE_NFD lbc_nfd_nogather_3d_dp 259 # include "lbc_nfd_nogather_generic.h90" 260 # undef ROUTINE_NFD 261 # define MULTI 262 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_dp 263 # include "lbc_nfd_nogather_generic.h90" 264 # undef ROUTINE_NFD 265 # undef MULTI 266 # undef DIM_3d 267 ! 268 ! !== 4D array and array of 4D pointer ==! 269 ! 270 # define DIM_4d 271 # define ROUTINE_NFD lbc_nfd_nogather_4d_dp 272 # include "lbc_nfd_nogather_generic.h90" 273 # undef ROUTINE_NFD 274 !# define MULTI 275 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr 276 !# include "lbc_nfd_nogather_generic.h90" 277 !# undef ROUTINE_NFD 278 !# undef MULTI 279 # undef DIM_4d 280 281 !!---------------------------------------------------------------------- 282 166 283 167 284 -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/lib_mpp.F90
r12512 r13766 67 67 PUBLIC mpp_ini_znl 68 68 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 69 PUBLIC mppsend_sp, mpprecv_sp ! needed by TAM and ICB routines 70 PUBLIC mppsend_dp, mpprecv_dp ! needed by TAM and ICB routines 69 71 PUBLIC mpp_report 70 72 PUBLIC mpp_bcast_nml 71 73 PUBLIC tic_tac 72 74 #if ! defined key_mpp_mpi 75 PUBLIC MPI_wait 73 76 PUBLIC MPI_Wtime 74 77 #endif … … 79 82 !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ 80 83 INTERFACE mpp_min 81 MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 84 MODULE PROCEDURE mppmin_a_int, mppmin_int 85 MODULE PROCEDURE mppmin_a_real_sp, mppmin_real_sp 86 MODULE PROCEDURE mppmin_a_real_dp, mppmin_real_dp 82 87 END INTERFACE 83 88 INTERFACE mpp_max 84 MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 89 MODULE PROCEDURE mppmax_a_int, mppmax_int 90 MODULE PROCEDURE mppmax_a_real_sp, mppmax_real_sp 91 MODULE PROCEDURE mppmax_a_real_dp, mppmax_real_dp 85 92 END INTERFACE 86 93 INTERFACE mpp_sum 87 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 88 & mppsum_realdd, mppsum_a_realdd 94 MODULE PROCEDURE mppsum_a_int, mppsum_int 95 MODULE PROCEDURE mppsum_realdd, mppsum_a_realdd 96 MODULE PROCEDURE mppsum_a_real_sp, mppsum_real_sp 97 MODULE PROCEDURE mppsum_a_real_dp, mppsum_real_dp 89 98 END INTERFACE 90 99 INTERFACE mpp_minloc 91 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 100 MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp 101 MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp 92 102 END INTERFACE 93 103 INTERFACE mpp_maxloc 94 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 104 MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp 105 MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp 95 106 END INTERFACE 96 107 … … 105 116 #else 106 117 INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 118 INTEGER, PUBLIC, PARAMETER :: MPI_REAL = 4 107 119 INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 108 120 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag … … 137 149 138 150 ! Communications summary report 139 CHARACTER(len= 128), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines140 CHARACTER(len= 128), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines141 CHARACTER(len= 128), DIMENSION(:), ALLOCATABLE :: crname_dlg !: names of delayed global comm calling routines151 CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines 152 CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines 153 CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_dlg !: names of delayed global comm calling routines 142 154 INTEGER, PUBLIC :: ncom_stp = 0 !: copy of time step # istp 143 155 INTEGER, PUBLIC :: ncom_fsbc = 1 !: copy of sbc time step # nn_fsbc … … 158 170 TYPE, PUBLIC :: DELAYARR 159 171 REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() 160 COMPLEX( wp), POINTER, DIMENSION(:) :: y1d => NULL()172 COMPLEX(dp), POINTER, DIMENSION(:) :: y1d => NULL() 161 173 END TYPE DELAYARR 162 174 TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR … … 164 176 165 177 ! timing summary report 166 REAL( wp), DIMENSION(2), PUBLIC :: waiting_time = 0._wp167 REAL( wp) , PUBLIC :: compute_time = 0._wp, elapsed_time = 0._wp178 REAL(dp), DIMENSION(2), PUBLIC :: waiting_time = 0._dp 179 REAL(dp) , PUBLIC :: compute_time = 0._dp, elapsed_time = 0._dp 168 180 169 181 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend … … 251 263 !! 252 264 INTEGER :: iflag 265 INTEGER :: mpi_working_type 266 !!---------------------------------------------------------------------- 267 ! 268 #if defined key_mpp_mpi 269 IF (wp == dp) THEN 270 mpi_working_type = mpi_double_precision 271 ELSE 272 mpi_working_type = mpi_real 273 END IF 274 CALL mpi_isend( pmess, kbytes, mpi_working_type, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 275 #endif 276 ! 277 END SUBROUTINE mppsend 278 279 280 SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req ) 281 !!---------------------------------------------------------------------- 282 !! *** routine mppsend *** 283 !! 284 !! ** Purpose : Send messag passing array 285 !! 286 !!---------------------------------------------------------------------- 287 REAL(dp), INTENT(inout) :: pmess(*) ! array of real 288 INTEGER , INTENT(in ) :: kbytes ! size of the array pmess 289 INTEGER , INTENT(in ) :: kdest ! receive process number 290 INTEGER , INTENT(in ) :: ktyp ! tag of the message 291 INTEGER , INTENT(in ) :: md_req ! argument for isend 292 !! 293 INTEGER :: iflag 253 294 !!---------------------------------------------------------------------- 254 295 ! … … 257 298 #endif 258 299 ! 259 END SUBROUTINE mppsend 300 END SUBROUTINE mppsend_dp 301 302 303 SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req ) 304 !!---------------------------------------------------------------------- 305 !! *** routine mppsend *** 306 !! 307 !! ** Purpose : Send messag passing array 308 !! 309 !!---------------------------------------------------------------------- 310 REAL(sp), INTENT(inout) :: pmess(*) ! array of real 311 INTEGER , INTENT(in ) :: kbytes ! size of the array pmess 312 INTEGER , INTENT(in ) :: kdest ! receive process number 313 INTEGER , INTENT(in ) :: ktyp ! tag of the message 314 INTEGER , INTENT(in ) :: md_req ! argument for isend 315 !! 316 INTEGER :: iflag 317 !!---------------------------------------------------------------------- 318 ! 319 #if defined key_mpp_mpi 320 CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 321 #endif 322 ! 323 END SUBROUTINE mppsend_sp 260 324 261 325 … … 275 339 INTEGER :: iflag 276 340 INTEGER :: use_source 341 INTEGER :: mpi_working_type 277 342 !!---------------------------------------------------------------------- 278 343 ! … … 283 348 IF( PRESENT(ksource) ) use_source = ksource 284 349 ! 350 IF (wp == dp) THEN 351 mpi_working_type = mpi_double_precision 352 ELSE 353 mpi_working_type = mpi_real 354 END IF 355 CALL mpi_recv( pmess, kbytes, mpi_working_type, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 356 #endif 357 ! 358 END SUBROUTINE mpprecv 359 360 SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource ) 361 !!---------------------------------------------------------------------- 362 !! *** routine mpprecv *** 363 !! 364 !! ** Purpose : Receive messag passing array 365 !! 366 !!---------------------------------------------------------------------- 367 REAL(dp), INTENT(inout) :: pmess(*) ! array of real 368 INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess 369 INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message 370 INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number 371 !! 372 INTEGER :: istatus(mpi_status_size) 373 INTEGER :: iflag 374 INTEGER :: use_source 375 !!---------------------------------------------------------------------- 376 ! 377 #if defined key_mpp_mpi 378 ! If a specific process number has been passed to the receive call, 379 ! use that one. Default is to use mpi_any_source 380 use_source = mpi_any_source 381 IF( PRESENT(ksource) ) use_source = ksource 382 ! 285 383 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 286 384 #endif 287 385 ! 288 END SUBROUTINE mpprecv 386 END SUBROUTINE mpprecv_dp 387 388 389 SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource ) 390 !!---------------------------------------------------------------------- 391 !! *** routine mpprecv *** 392 !! 393 !! ** Purpose : Receive messag passing array 394 !! 395 !!---------------------------------------------------------------------- 396 REAL(sp), INTENT(inout) :: pmess(*) ! array of real 397 INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess 398 INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message 399 INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number 400 !! 401 INTEGER :: istatus(mpi_status_size) 402 INTEGER :: iflag 403 INTEGER :: use_source 404 !!---------------------------------------------------------------------- 405 ! 406 #if defined key_mpp_mpi 407 ! If a specific process number has been passed to the receive call, 408 ! use that one. Default is to use mpi_any_source 409 use_source = mpi_any_source 410 IF( PRESENT(ksource) ) use_source = ksource 411 ! 412 CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 413 #endif 414 ! 415 END SUBROUTINE mpprecv_sp 289 416 290 417 … … 351 478 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 352 479 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 353 COMPLEX( wp), INTENT(in ), DIMENSION(:) :: y_in480 COMPLEX(dp), INTENT(in ), DIMENSION(:) :: y_in 354 481 REAL(wp), INTENT( out), DIMENSION(:) :: pout 355 482 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine … … 359 486 INTEGER :: idvar 360 487 INTEGER :: ierr, ilocalcomm 361 COMPLEX( wp), ALLOCATABLE, DIMENSION(:) :: ytmp488 COMPLEX(dp), ALLOCATABLE, DIMENSION(:) :: ytmp 362 489 !!---------------------------------------------------------------------- 363 490 #if defined key_mpp_mpi … … 384 511 ALLOCATE(todelay(idvar)%y1d(isz)) 385 512 todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0., wp) ! create %y1d, complex variable needed by mpi_sumdd 513 ndelayid(idvar) = MPI_REQUEST_NULL ! initialised request to a valid value 386 514 END IF 387 515 ENDIF … … 391 519 ALLOCATE(todelay(idvar)%z1d(isz), todelay(idvar)%y1d(isz)) ! allocate also %z1d as used for the restart 392 520 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) ! get %y1d 393 todelay(idvar)%z1d(:) = REAL(todelay(idvar)%y1d(:), wp) ! define %z1d from %y1d394 ENDIF 395 396 IF( ndelayid(idvar) > 0 )CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received521 ndelayid(idvar) = MPI_REQUEST_NULL 522 ENDIF 523 524 CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received 397 525 398 526 ! send back pout from todelay(idvar)%z1d defined at previous call … … 403 531 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 404 532 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) 405 ndelayid(idvar) = 1533 ndelayid(idvar) = MPI_REQUEST_NULL 406 534 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 407 535 # else … … 432 560 INTEGER :: idvar 433 561 INTEGER :: ierr, ilocalcomm 434 !!---------------------------------------------------------------------- 435 #if defined key_mpp_mpi 562 INTEGER :: MPI_TYPE 563 !!---------------------------------------------------------------------- 564 565 #if defined key_mpp_mpi 566 if( wp == dp ) then 567 MPI_TYPE = MPI_DOUBLE_PRECISION 568 else if ( wp == sp ) then 569 MPI_TYPE = MPI_REAL 570 else 571 CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) 572 573 end if 574 436 575 ilocalcomm = mpi_comm_oce 437 576 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 453 592 DEALLOCATE(todelay(idvar)%z1d) 454 593 ndelayid(idvar) = -1 ! do as if we had no restart 594 ELSE 595 ndelayid(idvar) = MPI_REQUEST_NULL 455 596 END IF 456 597 ENDIF … … 460 601 ALLOCATE(todelay(idvar)%z1d(isz)) 461 602 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) ! get %z1d 462 ENDIF 463 464 IF( ndelayid(idvar) > 0 ) CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received 603 ndelayid(idvar) = MPI_REQUEST_NULL 604 ENDIF 605 606 CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received 465 607 466 608 ! send back pout from todelay(idvar)%z1d defined at previous call … … 468 610 469 611 ! send p_in into todelay(idvar)%z1d with a non-blocking communication 612 ! (PM) Should we get rid of MPI2 option ? MPI3 was release in 2013. Who is still using MPI2 ? 470 613 # if defined key_mpi2 471 614 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 472 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) 473 ndelayid(idvar) = 1 615 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ierr ) 474 616 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 475 617 # else 476 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_ DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr )618 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 477 619 # endif 478 620 #else … … 494 636 !!---------------------------------------------------------------------- 495 637 #if defined key_mpp_mpi 496 IF( ndelayid(kid) /= -2 ) THEN 497 #if ! defined key_mpi2 498 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 499 CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! make sure todelay(kid) is received 500 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 501 #endif 502 IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d 503 ndelayid(kid) = -2 ! add flag to know that mpi_wait was already called on kid 504 ENDIF 638 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 639 ! test on ndelayid(kid) useless as mpi_wait return immediatly if the request handle is MPI_REQUEST_NULL 640 CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! after this ndelayid(kid) = MPI_REQUEST_NULL 641 IF( ln_timing ) CALL tic_tac( .FALSE., ld_global = .TRUE.) 642 IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d 505 643 #endif 506 644 END SUBROUTINE mpp_delay_rcv … … 551 689 # undef INTEGER_TYPE 552 690 ! 691 !! 692 !! ---- SINGLE PRECISION VERSIONS 693 !! 694 # define SINGLE_PRECISION 553 695 # define REAL_TYPE 554 696 # define DIM_0d 555 # define ROUTINE_ALLREDUCE mppmax_real 697 # define ROUTINE_ALLREDUCE mppmax_real_sp 556 698 # include "mpp_allreduce_generic.h90" 557 699 # undef ROUTINE_ALLREDUCE 558 700 # undef DIM_0d 559 701 # define DIM_1d 560 # define ROUTINE_ALLREDUCE mppmax_a_real 702 # define ROUTINE_ALLREDUCE mppmax_a_real_sp 703 # include "mpp_allreduce_generic.h90" 704 # undef ROUTINE_ALLREDUCE 705 # undef DIM_1d 706 # undef SINGLE_PRECISION 707 !! 708 !! 709 !! ---- DOUBLE PRECISION VERSIONS 710 !! 711 ! 712 # define DIM_0d 713 # define ROUTINE_ALLREDUCE mppmax_real_dp 714 # include "mpp_allreduce_generic.h90" 715 # undef ROUTINE_ALLREDUCE 716 # undef DIM_0d 717 # define DIM_1d 718 # define ROUTINE_ALLREDUCE mppmax_a_real_dp 561 719 # include "mpp_allreduce_generic.h90" 562 720 # undef ROUTINE_ALLREDUCE … … 583 741 # undef INTEGER_TYPE 584 742 ! 743 !! 744 !! ---- SINGLE PRECISION VERSIONS 745 !! 746 # define SINGLE_PRECISION 585 747 # define REAL_TYPE 586 748 # define DIM_0d 587 # define ROUTINE_ALLREDUCE mppmin_real 749 # define ROUTINE_ALLREDUCE mppmin_real_sp 588 750 # include "mpp_allreduce_generic.h90" 589 751 # undef ROUTINE_ALLREDUCE 590 752 # undef DIM_0d 591 753 # define DIM_1d 592 # define ROUTINE_ALLREDUCE mppmin_a_real 754 # define ROUTINE_ALLREDUCE mppmin_a_real_sp 755 # include "mpp_allreduce_generic.h90" 756 # undef ROUTINE_ALLREDUCE 757 # undef DIM_1d 758 # undef SINGLE_PRECISION 759 !! 760 !! ---- DOUBLE PRECISION VERSIONS 761 !! 762 763 # define DIM_0d 764 # define ROUTINE_ALLREDUCE mppmin_real_dp 765 # include "mpp_allreduce_generic.h90" 766 # undef ROUTINE_ALLREDUCE 767 # undef DIM_0d 768 # define DIM_1d 769 # define ROUTINE_ALLREDUCE mppmin_a_real_dp 593 770 # include "mpp_allreduce_generic.h90" 594 771 # undef ROUTINE_ALLREDUCE … … 616 793 # undef DIM_1d 617 794 # undef INTEGER_TYPE 618 ! 795 796 !! 797 !! ---- SINGLE PRECISION VERSIONS 798 !! 799 # define OPERATION_SUM 800 # define SINGLE_PRECISION 619 801 # define REAL_TYPE 620 802 # define DIM_0d 621 # define ROUTINE_ALLREDUCE mppsum_real 803 # define ROUTINE_ALLREDUCE mppsum_real_sp 622 804 # include "mpp_allreduce_generic.h90" 623 805 # undef ROUTINE_ALLREDUCE 624 806 # undef DIM_0d 625 807 # define DIM_1d 626 # define ROUTINE_ALLREDUCE mppsum_a_real 808 # define ROUTINE_ALLREDUCE mppsum_a_real_sp 809 # include "mpp_allreduce_generic.h90" 810 # undef ROUTINE_ALLREDUCE 811 # undef DIM_1d 812 # undef REAL_TYPE 813 # undef OPERATION_SUM 814 815 # undef SINGLE_PRECISION 816 817 !! 818 !! ---- DOUBLE PRECISION VERSIONS 819 !! 820 # define OPERATION_SUM 821 # define REAL_TYPE 822 # define DIM_0d 823 # define ROUTINE_ALLREDUCE mppsum_real_dp 824 # include "mpp_allreduce_generic.h90" 825 # undef ROUTINE_ALLREDUCE 826 # undef DIM_0d 827 # define DIM_1d 828 # define ROUTINE_ALLREDUCE mppsum_a_real_dp 627 829 # include "mpp_allreduce_generic.h90" 628 830 # undef ROUTINE_ALLREDUCE … … 651 853 !!---------------------------------------------------------------------- 652 854 !! 855 !! 856 !! ---- SINGLE PRECISION VERSIONS 857 !! 858 # define SINGLE_PRECISION 653 859 # define OPERATION_MINLOC 654 860 # define DIM_2d 655 # define ROUTINE_LOC mpp_minloc2d 861 # define ROUTINE_LOC mpp_minloc2d_sp 656 862 # include "mpp_loc_generic.h90" 657 863 # undef ROUTINE_LOC 658 864 # undef DIM_2d 659 865 # define DIM_3d 660 # define ROUTINE_LOC mpp_minloc3d 866 # define ROUTINE_LOC mpp_minloc3d_sp 661 867 # include "mpp_loc_generic.h90" 662 868 # undef ROUTINE_LOC … … 666 872 # define OPERATION_MAXLOC 667 873 # define DIM_2d 668 # define ROUTINE_LOC mpp_maxloc2d 874 # define ROUTINE_LOC mpp_maxloc2d_sp 669 875 # include "mpp_loc_generic.h90" 670 876 # undef ROUTINE_LOC 671 877 # undef DIM_2d 672 878 # define DIM_3d 673 # define ROUTINE_LOC mpp_maxloc3d 879 # define ROUTINE_LOC mpp_maxloc3d_sp 674 880 # include "mpp_loc_generic.h90" 675 881 # undef ROUTINE_LOC 676 882 # undef DIM_3d 677 883 # undef OPERATION_MAXLOC 884 # undef SINGLE_PRECISION 885 !! 886 !! ---- DOUBLE PRECISION VERSIONS 887 !! 888 # define OPERATION_MINLOC 889 # define DIM_2d 890 # define ROUTINE_LOC mpp_minloc2d_dp 891 # include "mpp_loc_generic.h90" 892 # undef ROUTINE_LOC 893 # undef DIM_2d 894 # define DIM_3d 895 # define ROUTINE_LOC mpp_minloc3d_dp 896 # include "mpp_loc_generic.h90" 897 # undef ROUTINE_LOC 898 # undef DIM_3d 899 # undef OPERATION_MINLOC 900 901 # define OPERATION_MAXLOC 902 # define DIM_2d 903 # define ROUTINE_LOC mpp_maxloc2d_dp 904 # include "mpp_loc_generic.h90" 905 # undef ROUTINE_LOC 906 # undef DIM_2d 907 # define DIM_3d 908 # define ROUTINE_LOC mpp_maxloc3d_dp 909 # include "mpp_loc_generic.h90" 910 # undef ROUTINE_LOC 911 # undef DIM_3d 912 # undef OPERATION_MAXLOC 913 678 914 679 915 SUBROUTINE mppsync() … … 865 1101 ! Look for how many procs on the northern boundary 866 1102 ndim_rank_north = 0 867 DO jjproc = 1, jpni j868 IF( n jmppt(jjproc) == njmppmax) ndim_rank_north = ndim_rank_north + 11103 DO jjproc = 1, jpni 1104 IF( nfproc(jjproc) /= -1 ) ndim_rank_north = ndim_rank_north + 1 869 1105 END DO 870 1106 ! … … 876 1112 ! Note : the rank start at 0 in MPI 877 1113 ii = 0 878 DO ji = 1, jpni j879 IF ( n jmppt(ji) == njmppmax) THEN1114 DO ji = 1, jpni 1115 IF ( nfproc(ji) /= -1 ) THEN 880 1116 ii=ii+1 881 nrank_north(ii)= ji-11117 nrank_north(ii)=nfproc(ji) 882 1118 END IF 883 1119 END DO … … 904 1140 !!--------------------------------------------------------------------- 905 1141 INTEGER , INTENT(in) :: ilen, itype 906 COMPLEX( wp), DIMENSION(ilen), INTENT(in) :: ydda907 COMPLEX( wp), DIMENSION(ilen), INTENT(inout) :: yddb908 ! 909 REAL( wp) :: zerr, zt1, zt2 ! local work variables1142 COMPLEX(dp), DIMENSION(ilen), INTENT(in) :: ydda 1143 COMPLEX(dp), DIMENSION(ilen), INTENT(inout) :: yddb 1144 ! 1145 REAL(dp) :: zerr, zt1, zt2 ! local work variables 910 1146 INTEGER :: ji, ztmp ! local scalar 911 1147 !!--------------------------------------------------------------------- … … 1060 1296 LOGICAL, INTENT(IN) :: ld_tic 1061 1297 LOGICAL, OPTIONAL, INTENT(IN) :: ld_global 1062 REAL( wp), DIMENSION(2), SAVE :: tic_wt1063 REAL( wp), SAVE :: tic_ct = 0._wp1298 REAL(dp), DIMENSION(2), SAVE :: tic_wt 1299 REAL(dp), SAVE :: tic_ct = 0._dp 1064 1300 INTEGER :: ii 1065 1301 #if defined key_mpp_mpi … … 1074 1310 IF ( ld_tic ) THEN 1075 1311 tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time) 1076 IF ( tic_ct > 0.0_ wp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic1312 IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic 1077 1313 ELSE 1078 1314 waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac … … 1112 1348 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5 1113 1349 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1350 ! 1351 CHARACTER(LEN=8) :: clfmt ! writing format 1352 INTEGER :: inum 1114 1353 !!---------------------------------------------------------------------- 1115 1354 ! 1116 1355 nstop = nstop + 1 1117 1356 ! 1118 ! force to open ocean.output file if not already opened 1119 IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 1357 IF( cd1 == 'STOP' .AND. narea /= 1 ) THEN ! Immediate stop: add an arror message in 'ocean.output' file 1358 CALL ctl_opn( inum, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 1359 WRITE(inum,*) 1360 WRITE(inum,*) ' ==>>> Look for "E R R O R" messages in all existing *ocean.output* files' 1361 CLOSE(inum) 1362 ENDIF 1363 IF( numout == 6 ) THEN ! force to open ocean.output file if not already opened 1364 CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 1365 ENDIF 1120 1366 ! 1121 1367 WRITE(numout,*) … … 1145 1391 WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' 1146 1392 WRITE(numout,*) 1393 CALL FLUSH(numout) 1394 CALL SLEEP(60) ! make sure that all output and abort files are written by all cores. 60s should be enough... 1147 1395 CALL mppstop( ld_abort = .true. ) 1148 1396 ENDIF … … 1207 1455 ! 1208 1456 CHARACTER(len=80) :: clfile 1457 CHARACTER(LEN=10) :: clfmt ! writing format 1209 1458 INTEGER :: iost 1459 INTEGER :: idg ! number of digits 1210 1460 !!---------------------------------------------------------------------- 1211 1461 ! … … 1214 1464 clfile = TRIM(cdfile) 1215 1465 IF( PRESENT( karea ) ) THEN 1216 IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1 1466 IF( karea > 1 ) THEN 1467 ! Warning: jpnij is maybe not already defined when calling ctl_opn -> use mppsize instead of jpnij 1468 idg = MAX( INT(LOG10(REAL(MAX(1,mppsize-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 1469 WRITE(clfmt, "('(a,a,i', i1, '.', i1, ')')") idg, idg ! '(a,a,ix.x)' 1470 WRITE(clfile, clfmt) TRIM(clfile), '_', karea-1 1471 ENDIF 1217 1472 ENDIF 1218 1473 #if defined key_agrif -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/mpp_allreduce_generic.h90
r10425 r13766 1 1 ! !== IN: ptab is an array ==! 2 2 # if defined REAL_TYPE 3 # define ARRAY_TYPE(i) REAL(wp) , INTENT(inout) :: ARRAY_IN(i) 4 # define TMP_TYPE(i) REAL(wp) , ALLOCATABLE :: work(i) 5 # define MPI_TYPE mpi_double_precision 3 # if defined SINGLE_PRECISION 4 # define ARRAY_TYPE(i) REAL(sp) , INTENT(inout) :: ARRAY_IN(i) 5 # define TMP_TYPE(i) REAL(sp) , ALLOCATABLE :: work(i) 6 # define MPI_TYPE mpi_real 7 # else 8 # define ARRAY_TYPE(i) REAL(dp) , INTENT(inout) :: ARRAY_IN(i) 9 # define TMP_TYPE(i) REAL(dp) , ALLOCATABLE :: work(i) 10 # define MPI_TYPE mpi_double_precision 11 # endif 6 12 # endif 7 13 # if defined INTEGER_TYPE … … 11 17 # endif 12 18 # if defined COMPLEX_TYPE 13 # define ARRAY_TYPE(i) COMPLEX 14 # define TMP_TYPE(i) COMPLEX 19 # define ARRAY_TYPE(i) COMPLEX(dp) , INTENT(inout) :: ARRAY_IN(i) 20 # define TMP_TYPE(i) COMPLEX(dp) , ALLOCATABLE :: work(i) 15 21 # define MPI_TYPE mpi_double_complex 16 22 # endif … … 75 81 END SUBROUTINE ROUTINE_ALLREDUCE 76 82 83 #undef PRECISION 77 84 #undef ARRAY_TYPE 78 85 #undef ARRAY_IN -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/mpp_lnk_generic.h90
r11536 r13766 5 5 # define OPT_K(k) ,ipf 6 6 # if defined DIM_2d 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) 7 # if defined SINGLE_PRECISION 8 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) 9 # else 10 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) 11 # endif 8 12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 9 13 # define K_SIZE(ptab) 1 … … 11 15 # endif 12 16 # if defined DIM_3d 13 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) 17 # if defined SINGLE_PRECISION 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) 19 # else 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) 21 # endif 14 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 15 23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 17 25 # endif 18 26 # if defined DIM_4d 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) 27 # if defined SINGLE_PRECISION 28 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) 29 # else 30 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) 31 # endif 20 32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 21 33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) … … 23 35 # endif 24 36 #else 25 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 37 # if defined SINGLE_PRECISION 38 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 39 # else 40 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 41 # endif 26 42 # define NAT_IN(k) cd_nat 27 43 # define SGN_IN(k) psgn … … 45 61 #endif 46 62 63 # if defined SINGLE_PRECISION 64 # define PRECISION sp 65 # define SENDROUTINE mppsend_sp 66 # define RECVROUTINE mpprecv_sp 67 # else 68 # define PRECISION dp 69 # define SENDROUTINE mppsend_dp 70 # define RECVROUTINE mpprecv_dp 71 # endif 72 47 73 #if defined MULTI 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv , ihlcom)74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv ) 49 75 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 50 76 #else 51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv , ihlcom)77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv ) 52 78 #endif 53 79 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied … … 58 84 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 59 85 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 60 INTEGER ,OPTIONAL, INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated61 86 ! 62 87 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices … … 66 91 INTEGER :: ierr 67 92 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 68 INTEGER :: ihl ! number of ranks and rows to be communicated69 93 REAL(wp) :: zland 70 94 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 71 REAL( wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos72 REAL( wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos95 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 96 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 73 97 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 74 98 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive … … 83 107 ipl = L_SIZE(ptab) ! 4th - 84 108 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 85 !86 IF( PRESENT(ihlcom) ) THEN ; ihl = ihlcom87 ELSE ; ihl = 188 END IF89 109 ! 90 110 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) … … 149 169 ! 150 170 ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 151 isize = ihl* jpj * ipk * ipl * ipf171 isize = nn_hls * jpj * ipk * ipl * ipf 152 172 ! 153 173 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 154 IF( llsend_we ) ALLOCATE( zsnd_we( ihl,jpj,ipk,ipl,ipf) )155 IF( llsend_ea ) ALLOCATE( zsnd_ea( ihl,jpj,ipk,ipl,ipf) )156 IF( llrecv_we ) ALLOCATE( zrcv_we( ihl,jpj,ipk,ipl,ipf) )157 IF( llrecv_ea ) ALLOCATE( zrcv_ea( ihl,jpj,ipk,ipl,ipf) )174 IF( llsend_we ) ALLOCATE( zsnd_we(nn_hls,jpj,ipk,ipl,ipf) ) 175 IF( llsend_ea ) ALLOCATE( zsnd_ea(nn_hls,jpj,ipk,ipl,ipf) ) 176 IF( llrecv_we ) ALLOCATE( zrcv_we(nn_hls,jpj,ipk,ipl,ipf) ) 177 IF( llrecv_ea ) ALLOCATE( zrcv_ea(nn_hls,jpj,ipk,ipl,ipf) ) 158 178 ! 159 179 IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 160 ishift = ihl161 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl162 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! ihl + 1 -> 2*ihl180 ishift = nn_hls 181 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 182 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls 163 183 END DO ; END DO ; END DO ; END DO ; END DO 164 184 ENDIF 165 185 ! 166 186 IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 167 ishift = jpi - 2 * ihl168 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl169 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2* ihl + 1 -> jpi - ihl187 ishift = jpi - 2 * nn_hls 188 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 189 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls 170 190 END DO ; END DO ; END DO ; END DO ; END DO 171 191 ENDIF … … 174 194 ! 175 195 ! non-blocking send of the western/eastern side using local temporary arrays 176 IF( llsend_we ) CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we )177 IF( llsend_ea ) CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea )196 IF( llsend_we ) CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 197 IF( llsend_ea ) CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 178 198 ! blocking receive of the western/eastern halo in local temporary arrays 179 IF( llrecv_we ) CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe )180 IF( llrecv_ea ) CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea )199 IF( llrecv_we ) CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 200 IF( llrecv_ea ) CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 181 201 ! 182 202 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 189 209 ! 2.1 fill weastern halo 190 210 ! ---------------------- 191 ! ishift = 0 ! fill halo from ji = 1 to ihl211 ! ishift = 0 ! fill halo from ji = 1 to nn_hls 192 212 SELECT CASE ( ifill_we ) 193 213 CASE ( jpfillnothing ) ! no filling 194 214 CASE ( jpfillmpi ) ! use data received by MPI 195 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl196 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> ihl197 END DO ; END DO ; END DO ; END DO ; END DO215 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 216 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> nn_hls 217 END DO ; END DO ; END DO ; END DO ; END DO 198 218 CASE ( jpfillperio ) ! use east-weast periodicity 199 ishift2 = jpi - 2 * ihl200 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl219 ishift2 = jpi - 2 * nn_hls 220 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 201 221 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 202 END DO ; END DO ; END DO ; END DO ; END DO222 END DO ; END DO ; END DO ; END DO ; END DO 203 223 CASE ( jpfillcopy ) ! filling with inner domain values 204 DO jf = 1, ipf ! number of arrays to be treated 205 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 206 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 207 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) 208 END DO ; END DO ; END DO ; END DO 209 ENDIF 210 END DO 224 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 225 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 226 END DO ; END DO ; END DO ; END DO ; END DO 211 227 CASE ( jpfillcst ) ! filling with constant value 212 DO jf = 1, ipf ! number of arrays to be treated 213 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 214 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 215 ARRAY_IN(ji,jj,jk,jl,jf) = zland 216 END DO; END DO ; END DO ; END DO 217 ENDIF 218 END DO 228 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 229 ARRAY_IN(ji,jj,jk,jl,jf) = zland 230 END DO ; END DO ; END DO ; END DO ; END DO 219 231 END SELECT 220 232 ! 221 233 ! 2.2 fill eastern halo 222 234 ! --------------------- 223 ishift = jpi - ihl ! fill halo from ji = jpi-ihl+1 to jpi235 ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi 224 236 SELECT CASE ( ifill_ea ) 225 237 CASE ( jpfillnothing ) ! no filling 226 238 CASE ( jpfillmpi ) ! use data received by MPI 227 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl228 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - ihl+ 1 -> jpi239 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 240 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi 229 241 END DO ; END DO ; END DO ; END DO ; END DO 230 242 CASE ( jpfillperio ) ! use east-weast periodicity 231 ishift2 = ihl232 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl243 ishift2 = nn_hls 244 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 233 245 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 234 246 END DO ; END DO ; END DO ; END DO ; END DO 235 247 CASE ( jpfillcopy ) ! filling with inner domain values 236 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl248 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 237 249 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 238 250 END DO ; END DO ; END DO ; END DO ; END DO 239 251 CASE ( jpfillcst ) ! filling with constant value 240 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl252 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 241 253 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 242 END DO ; END DO ; END DO ; END DO ; END DO254 END DO ; END DO ; END DO ; END DO ; END DO 243 255 END SELECT 244 256 ! … … 252 264 ! 253 265 SELECT CASE ( jpni ) 254 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp255 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.266 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp 267 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs. 256 268 END SELECT 257 269 ! … … 264 276 ! ---------------------------------------------------- ! 265 277 ! 266 IF( llsend_so ) ALLOCATE( zsnd_so(jpi, ihl,ipk,ipl,ipf) )267 IF( llsend_no ) ALLOCATE( zsnd_no(jpi, ihl,ipk,ipl,ipf) )268 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi, ihl,ipk,ipl,ipf) )269 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi, ihl,ipk,ipl,ipf) )270 ! 271 isize = jpi * ihl* ipk * ipl * ipf278 IF( llsend_so ) ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf) ) 279 IF( llsend_no ) ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf) ) 280 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,nn_hls,ipk,ipl,ipf) ) 281 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,nn_hls,ipk,ipl,ipf) ) 282 ! 283 isize = jpi * nn_hls * ipk * ipl * ipf 272 284 273 285 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 274 286 IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 275 ishift = ihl276 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi277 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! ihl+1 -> 2*ihl287 ishift = nn_hls 288 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 289 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls 278 290 END DO ; END DO ; END DO ; END DO ; END DO 279 291 ENDIF 280 292 ! 281 293 IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 282 ishift = jpj - 2 * ihl283 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi284 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2* ihl+1 -> jpj-ihl294 ishift = jpj - 2 * nn_hls 295 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 296 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls 285 297 END DO ; END DO ; END DO ; END DO ; END DO 286 298 ENDIF … … 289 301 ! 290 302 ! non-blocking send of the southern/northern side 291 IF( llsend_so ) CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so )292 IF( llsend_no ) CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no )303 IF( llsend_so ) CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 304 IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 293 305 ! blocking receive of the southern/northern halo 294 IF( llrecv_so ) CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso )295 IF( llrecv_no ) CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono )306 IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso ) 307 IF( llrecv_no ) CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono ) 296 308 ! 297 309 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 303 315 ! 5.1 fill southern halo 304 316 ! ---------------------- 305 ! ishift = 0 ! fill halo from jj = 1 to ihl317 ! ishift = 0 ! fill halo from jj = 1 to nn_hls 306 318 SELECT CASE ( ifill_so ) 307 319 CASE ( jpfillnothing ) ! no filling 308 320 CASE ( jpfillmpi ) ! use data received by MPI 309 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi310 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> ihl311 END DO ; END DO ; END DO ; END DO ; END DO321 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 322 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls 323 END DO ; END DO ; END DO ; END DO ; END DO 312 324 CASE ( jpfillperio ) ! use north-south periodicity 313 ishift2 = jpj - 2 * ihl314 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi325 ishift2 = jpj - 2 * nn_hls 326 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 315 327 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 316 END DO ; END DO ; END DO ; END DO ; END DO328 END DO ; END DO ; END DO ; END DO ; END DO 317 329 CASE ( jpfillcopy ) ! filling with inner domain values 318 DO jf = 1, ipf ! number of arrays to be treated 319 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 320 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 321 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) 322 END DO ; END DO ; END DO ; END DO 323 ENDIF 324 END DO 330 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 331 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf) 332 END DO ; END DO ; END DO ; END DO ; END DO 325 333 CASE ( jpfillcst ) ! filling with constant value 326 DO jf = 1, ipf ! number of arrays to be treated 327 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 328 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 329 ARRAY_IN(ji,jj,jk,jl,jf) = zland 330 END DO; END DO ; END DO ; END DO 331 ENDIF 332 END DO 334 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 335 ARRAY_IN(ji,jj,jk,jl,jf) = zland 336 END DO ; END DO ; END DO ; END DO ; END DO 333 337 END SELECT 334 338 ! 335 339 ! 5.2 fill northern halo 336 340 ! ---------------------- 337 ishift = jpj - ihl ! fill halo from jj = jpj-ihl+1 to jpj341 ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj 338 342 SELECT CASE ( ifill_no ) 339 343 CASE ( jpfillnothing ) ! no filling 340 344 CASE ( jpfillmpi ) ! use data received by MPI 341 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi342 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj- ihl+1 -> jpj345 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 346 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj 343 347 END DO ; END DO ; END DO ; END DO ; END DO 344 348 CASE ( jpfillperio ) ! use north-south periodicity 345 ishift2 = ihl346 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi349 ishift2 = nn_hls 350 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 347 351 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 348 END DO ; END DO ; END DO ; END DO ; END DO352 END DO ; END DO ; END DO ; END DO ; END DO 349 353 CASE ( jpfillcopy ) ! filling with inner domain values 350 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 351 355 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 352 END DO ; END DO ; END DO ; END DO ; END DO356 END DO ; END DO ; END DO ; END DO ; END DO 353 357 CASE ( jpfillcst ) ! filling with constant value 354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi358 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 355 359 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 356 END DO ; END DO ; END DO ; END DO ; END DO360 END DO ; END DO ; END DO ; END DO ; END DO 357 361 END SELECT 358 362 ! … … 384 388 ! 385 389 END SUBROUTINE ROUTINE_LNK 386 390 #undef PRECISION 391 #undef SENDROUTINE 392 #undef RECVROUTINE 387 393 #undef ARRAY_TYPE 388 394 #undef NAT_IN -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/mpp_loc_generic.h90
r10716 r13766 1 1 !== IN: ptab is an array ==! 2 # define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k) 3 # define MASK_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: MASK_IN(i,j,k) 2 # if defined SINGLE_PRECISION 3 # define ARRAY_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: ARRAY_IN(i,j,k) 4 #if defined key_mpp_mpi 5 # define MPI_TYPE MPI_2REAL 6 #endif 7 # define PRECISION sp 8 # else 9 # define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) 10 #if defined key_mpp_mpi 11 # define MPI_TYPE MPI_2DOUBLE_PRECISION 12 #endif 13 # define PRECISION dp 14 # endif 15 4 16 # if defined DIM_2d 5 17 # define ARRAY_IN(i,j,k) ptab(i,j) 6 # define MASK_IN(i,j,k) pmask(i,j)18 # define MASK_IN(i,j,k) ldmsk(i,j) 7 19 # define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(2) 8 20 # define K_SIZE(ptab) 1 … … 10 22 # if defined DIM_3d 11 23 # define ARRAY_IN(i,j,k) ptab(i,j,k) 12 # define MASK_IN(i,j,k) pmask(i,j,k)24 # define MASK_IN(i,j,k) ldmsk(i,j,k) 13 25 # define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(3) 14 26 # define K_SIZE(ptab) SIZE(ptab,3) 15 27 # endif 16 28 # if defined OPERATION_MAXLOC 17 # define MPI_OPERATION mpi_maxloc29 # define MPI_OPERATION MPI_MAXLOC 18 30 # define LOC_OPERATION MAXLOC 19 31 # define ERRVAL -HUGE 20 32 # endif 21 33 # if defined OPERATION_MINLOC 22 # define MPI_OPERATION mpi_minloc34 # define MPI_OPERATION MPI_MINLOC 23 35 # define LOC_OPERATION MINLOC 24 36 # define ERRVAL HUGE 25 37 # endif 26 38 27 SUBROUTINE ROUTINE_LOC( cdname, ptab, pmask, pmin, kindex)39 SUBROUTINE ROUTINE_LOC( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) 28 40 !!---------------------------------------------------------------------- 29 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine41 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 30 42 ARRAY_TYPE(:,:,:) ! array on which loctrans operation is applied 31 MASK_TYPE(:,:,:)! local mask32 REAL( wp), INTENT( out) :: pmin ! Global minimum of ptab43 LOGICAL , INTENT(in ) :: MASK_IN(:,:,:) ! local mask 44 REAL(PRECISION) , INTENT( out) :: pmin ! Global minimum of ptab 33 45 INDEX_TYPE(:) ! index of minimum in global frame 34 # if defined key_mpp_mpi 46 LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex 35 47 ! 36 48 INTEGER :: ierror, ii, idim 37 49 INTEGER :: index0 38 REAL(wp) :: zmin ! local minimum39 50 INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs 40 REAL(wp), DIMENSION(2,1) :: zain, zaout 51 REAL(PRECISION) :: zmin ! local minimum 52 REAL(PRECISION), DIMENSION(2,1) :: zain, zaout 53 LOGICAL :: llhalo 41 54 !!----------------------------------------------------------------------- 42 55 ! 43 56 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) 44 57 ! 58 IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo 59 ELSE ; llhalo = .FALSE. 60 ENDIF 61 ! 45 62 idim = SIZE(kindex) 46 63 ! 47 IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN 48 ! special case for land processors 49 zmin = ERRVAL(zmin) 50 index0 = 0 51 ELSE 64 IF ( ANY( MASK_IN(:,:,:) ) ) THEN ! there is at least 1 valid point... 65 ! 52 66 ALLOCATE ( ilocs(idim) ) 53 67 ! 54 ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp)68 ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) ) 55 69 zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3)) 56 70 ! 57 71 kindex(1) = mig( ilocs(1) ) 58 # 72 #if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 59 73 kindex(2) = mjg( ilocs(2) ) 60 # 61 # 74 #endif 75 #if defined DIM_3d /* avoid warning when kindex has 2 elements */ 62 76 kindex(3) = ilocs(3) 63 # 77 #endif 64 78 ! 65 79 DEALLOCATE (ilocs) 66 80 ! 67 81 index0 = kindex(1)-1 ! 1d index starting at 0 68 # 82 #if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 69 83 index0 = index0 + jpiglo * (kindex(2)-1) 70 # 71 # 84 #endif 85 #if defined DIM_3d /* avoid warning when kindex has 2 elements */ 72 86 index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) 73 # endif 87 #endif 88 ELSE 89 ! special case for land processors 90 zmin = ERRVAL(zmin) 91 index0 = 0 74 92 END IF 93 ! 75 94 zain(1,:) = zmin 76 zain(2,:) = REAL(index0, wp)95 zain(2,:) = REAL(index0, PRECISION) 77 96 ! 97 #if defined key_mpp_mpi 78 98 IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) 79 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_ 2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror)99 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_TYPE, MPI_OPERATION ,MPI_COMM_OCE, ierror) 80 100 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 101 #else 102 zaout(:,:) = zain(:,:) 103 #endif 81 104 ! 82 105 pmin = zaout(1,1) 83 106 index0 = NINT( zaout(2,1) ) 84 # 107 #if defined DIM_3d /* avoid warning when kindex has 2 elements */ 85 108 kindex(3) = index0 / (jpiglo*jpjglo) 86 109 index0 = index0 - kindex(3) * (jpiglo*jpjglo) 87 # 88 # 110 #endif 111 #if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 89 112 kindex(2) = index0 / jpiglo 90 113 index0 = index0 - kindex(2) * jpiglo 91 # 114 #endif 92 115 kindex(1) = index0 93 116 kindex(:) = kindex(:) + 1 ! start indices at 1 94 #else 95 kindex = 0 ; pmin = 0. 96 WRITE(*,*) 'ROUTINE_LOC: You should not have seen this print! error?' 117 118 IF( .NOT. llhalo ) THEN 119 kindex(1) = kindex(1) - nn_hls 120 #if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 121 kindex(2) = kindex(2) - nn_hls 97 122 #endif 98 123 ENDIF 124 99 125 END SUBROUTINE ROUTINE_LOC 100 126 127 128 #undef PRECISION 101 129 #undef ARRAY_TYPE 102 #undef MAX_TYPE103 130 #undef ARRAY_IN 104 131 #undef MASK_IN 105 132 #undef K_SIZE 133 #if defined key_mpp_mpi 134 # undef MPI_TYPE 135 #endif 106 136 #undef MPI_OPERATION 107 137 #undef LOC_OPERATION -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/mpp_nfd_generic.h90
r11536 r13766 5 5 # define LBC_ARG (jf) 6 6 # if defined DIM_2d 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) 7 # if defined SINGLE_PRECISION 8 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) 9 # else 10 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) 11 # endif 8 12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 9 13 # define K_SIZE(ptab) 1 … … 11 15 # endif 12 16 # if defined DIM_3d 13 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) 17 # if defined SINGLE_PRECISION 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) 19 # else 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) 21 # endif 14 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 15 23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 17 25 # endif 18 26 # if defined DIM_4d 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) 27 # if defined SINGLE_PRECISION 28 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) 29 # else 30 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) 31 # endif 20 32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 21 33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) … … 24 36 #else 25 37 ! !== IN: ptab is an array ==! 26 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 38 # if defined SINGLE_PRECISION 39 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 40 # else 41 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 42 # endif 27 43 # define NAT_IN(k) cd_nat 28 44 # define SGN_IN(k) psgn … … 46 62 #endif 47 63 48 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 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 ) 49 79 !!---------------------------------------------------------------------- 50 80 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 51 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 52 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) 53 85 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 54 86 ! 87 LOGICAL :: ll_add_line 55 88 INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices 56 INTEGER :: ipi, ipj, ip k, ipl, ipf! dimension of the input array89 INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array 57 90 INTEGER :: imigr, iihom, ijhom ! local integers 58 INTEGER :: ierr, ibuffsize, ilci, ildi, ilei, iilb 59 INTEGER :: ij, iproc 91 INTEGER :: ierr, ibuffsize, iis0, iie0, impp 92 INTEGER :: ii1, ii2, ij1, ij2 93 INTEGER :: ipimax, i0max 94 INTEGER :: ij, iproc, ipni, ijnr 60 95 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 61 96 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 62 97 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 63 98 ! ! Workspace for message transfers avoiding mpi_allgather 64 INTEGER :: ip f_j! sum of lines for all multi fields65 INTEGER :: js ! counter66 INTEGER , DIMENSION(:,:),ALLOCATABLE :: jj_s ! position of sent lines67 INTEGER , DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sentlines68 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl69 REAL( wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr70 REAL( wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk71 REAL( wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio99 INTEGER :: ipj_b ! sum of lines for all multi fields 100 INTEGER :: i012 ! 0, 1 or 2 101 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_s ! position of sent lines 102 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines 103 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 104 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 105 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztabglo, znorthloc 106 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo 72 107 !!---------------------------------------------------------------------- 73 108 ! … … 78 113 IF( l_north_nogather ) THEN !== no allgather exchanges ==! 79 114 80 ALLOCATE(ipj_s(ipf)) 81 82 ipj = 2 ! Max 2nd dimension of message transfers (last two j-line only) 83 ipj_s(:) = 1 ! Real 2nd dimension of message transfers (depending on perf requirement) 84 ! by default, only one line is exchanged 85 86 ALLOCATE( jj_s(ipf,2) ) 87 88 ! re-define number of exchanged lines : 89 ! must be two during the first two time steps 90 ! to correct possible incoherent values on North fold lines from restart 91 115 ! --- define number of exchanged lines --- 116 ! 117 ! In theory we should exchange only nn_hls lines. 118 ! 119 ! 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 duplicated 126 ! - 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) 128 ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 129 ! This explain why these duplicated points may have different values even if they are at the exact same location. 130 ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. 131 ! This is slightly slower but necessary to avoid different values on identical grid points!! 132 ! 92 133 !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! 93 134 !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! 94 135 !!!!!!!!! I don't know why we must do that... !!!!!!!! 95 136 l_full_nf_update = .TRUE. 96 97 ! Two lines update (slower but necessary to avoid different values ion identical grid points 98 IF ( l_full_nf_update .OR. & ! if coupling fields 99 ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) & ! at first time step, if not restart 100 ipj_s(:) = 2 137 ! also force it if not restart during the first 2 steps (leap frog?) 138 ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) 139 140 ALLOCATE(ipj_s(ipf)) ! how many lines do we exchange? 141 IF( ll_add_line ) THEN 142 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' /) ) 144 END DO 145 ELSE 146 ipj_s(:) = nn_hls 147 ENDIF 148 149 ipj = MAXVAL(ipj_s(:)) ! Max 2nd dimension of message transfers 150 ipj_b = SUM( ipj_s(:)) ! Total number of lines to be exchanged 151 ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) ) 101 152 102 153 ! Index of modifying lines in input 154 ij1 = 0 103 155 DO jf = 1, ipf ! Loop over the number of arrays to be processed 104 156 ! 105 157 SELECT CASE ( npolj ) 106 !107 158 CASE ( 3, 4 ) ! * North fold T-point pivot 108 !109 159 SELECT CASE ( NAT_IN(jf) ) 110 ! 111 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 112 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 113 CASE ( 'V' , 'F' ) ! V-, F-point 114 jj_s(jf,1) = nlcj - 3 ; jj_s(jf,2) = nlcj - 2 160 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 161 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point 115 162 END SELECT 116 ! 117 CASE ( 5, 6 ) ! * North fold F-point pivot 163 CASE ( 5, 6 ) ! * North fold F-point pivot 118 164 SELECT CASE ( NAT_IN(jf) ) 119 ! 120 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 121 jj_s(jf,1) = nlcj - 1 122 ipj_s(jf) = 1 ! need only one line anyway 123 CASE ( 'V' , 'F' ) ! V-, F-point 124 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 165 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 166 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point 125 167 END SELECT 126 !127 168 END SELECT 128 ! 129 ENDDO 130 ! 131 ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged 132 ! 133 ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 134 ! 135 js = 0 136 DO jf = 1, ipf ! Loop over the number of arrays to be processed 169 ! 137 170 DO jj = 1, ipj_s(jf) 138 js = js + 1 139 DO jl = 1, ipl 140 DO jk = 1, ipk 141 znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 142 END DO 143 END DO 171 ij1 = ij1 + 1 172 jj_b(jj,jf) = ij1 173 jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012 144 174 END DO 175 ! 145 176 END DO 146 177 ! 147 ibuffsize = jpimax * ipf_j * ipk * ipl 148 ! 149 ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 150 ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) ) 151 ! when some processors of the north fold are suppressed, 152 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 153 ! and we need a default definition to 0. 154 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 155 IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 178 ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) ) ! store all the data to be sent in a buffer array 179 ibuffsize = jpimax * ipj_b * ipk * ipl 180 ! 181 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 182 DO jj = 1, ipj_s(jf) 183 ij1 = jj_b(jj,jf) 184 ij2 = jj_s(jj,jf) 185 DO ji = 1, jpi 186 ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 187 END DO 188 DO ji = jpi+1, jpimax 189 ztabb(ji,ij1,jk,jl) = HUGEVAL(0.) ! avoid sending uninitialized values (make sure we don't use it) 190 END DO 191 END DO 192 END DO ; END DO ; END DO 156 193 ! 157 194 ! start waiting time measurement 158 195 IF( ln_timing ) CALL tic_tac(.TRUE.) 159 196 ! 197 ! send the data as soon as possible 160 198 DO jr = 1, nsndto 161 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 162 CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 199 iproc = nfproc(isendto(jr)) 200 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 201 CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 163 202 ENDIF 164 203 END DO 165 204 ! 205 ipimax = jpimax * jpmaxngh 206 ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) ) 207 ! 208 DO jr = 1, nsndto 209 ! 210 ipni = isendto(jr) 211 iproc = nfproc(ipni) 212 ipi = nfjpi (ipni) 213 ! 214 IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column 215 ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain 216 ENDIF 217 IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column 218 ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain 219 ENDIF 220 impp = nfimpp(ipni) - nfimpp(isendto(1)) 221 ! 222 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 223 ! 224 SELECT CASE ( kfillmode ) 225 CASE ( jpfillnothing ) ! no filling 226 CASE ( jpfillcopy ) ! filling with inner domain values 227 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 228 DO jj = 1, ipj_s(jf) 229 ij1 = jj_b(jj,jf) 230 ij2 = jj_s(jj,jf) 231 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 point 233 END DO 234 END DO 235 END DO ; END DO ; END DO 236 CASE ( jpfillcst ) ! filling with constant value 237 DO jl = 1, ipl ; DO jk = 1, ipk 238 DO jj = 1, ipj_b 239 DO ji = iis0, iie0 240 ztabr(impp+ji,jj,jk,jl) = pfillval 241 END DO 242 END DO 243 END DO ; END DO 244 END SELECT 245 ! 246 ELSE IF( iproc == narea-1 ) THEN ! get data from myself! 247 ! 248 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 249 DO jj = 1, ipj_s(jf) 250 ij1 = jj_b(jj,jf) 251 ij2 = jj_s(jj,jf) 252 DO ji = iis0, iie0 253 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 254 END DO 255 END DO 256 END DO ; END DO ; END DO 257 ! 258 ELSE ! get data from a neighbour trough communication 259 ! 260 CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 261 DO jl = 1, ipl ; DO jk = 1, ipk 262 DO jj = 1, ipj_b 263 DO ji = iis0, iie0 264 ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl) 265 END DO 266 END DO 267 END DO ; END DO 268 269 ENDIF 270 ! 271 END DO ! nsndto 272 ! 273 IF( ln_timing ) CALL tic_tac(.FALSE.) 274 ! 275 ! North fold boundary condition 276 ! 277 DO jf = 1, ipf 278 ij1 = jj_b( 1 ,jf) 279 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 ) 281 END DO 282 ! 283 DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s ) 284 ! 166 285 DO jr = 1,nsndto 167 iproc = nfipproc(isendto(jr),jpnj) 168 IF(iproc /= -1) THEN 169 iilb = nimppt(iproc+1) 170 ilci = nlcit (iproc+1) 171 ildi = nldit (iproc+1) 172 ilei = nleit (iproc+1) 173 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 174 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 175 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 176 ENDIF 286 iproc = nfproc(isendto(jr)) 177 287 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 178 CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 179 js = 0 180 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 181 js = js + 1 182 DO jl = 1, ipl 183 DO jk = 1, ipk 184 DO ji = ildi, ilei 185 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 186 END DO 187 END DO 188 END DO 189 END DO; END DO 190 ELSE IF( iproc == narea-1 ) THEN 191 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 192 DO jl = 1, ipl 193 DO jk = 1, ipk 194 DO ji = ildi, ilei 195 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 196 END DO 197 END DO 198 END DO 199 END DO; END DO 288 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate 200 289 ENDIF 201 290 END DO 202 DO jr = 1,nsndto 203 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 204 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 205 ENDIF 206 END DO 207 ! 208 IF( ln_timing ) CALL tic_tac(.FALSE.) 209 ! 210 ! North fold boundary condition 211 ! 212 DO jf = 1, ipf 213 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 214 END DO 215 ! 216 DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 291 DEALLOCATE( ztabb ) 217 292 ! 218 293 ELSE !== allgather exchanges ==! 219 294 ! 220 ipj = 4 ! 2nd dimension of message transfers (last j-lines) 221 ! 222 ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 223 ! 224 DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab 225 DO jl = 1, ipl 226 DO jk = 1, ipk 227 DO jj = nlcj - ipj +1, nlcj 228 ij = jj - nlcj + ipj 229 znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 230 END DO 295 ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) 296 ipj = nn_hls + 2 297 ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) 298 ipj2 = 2 * nn_hls + 2 299 ! 300 i0max = jpimax - 2 * nn_hls 301 ibuffsize = i0max * ipj * ipk * ipl * ipf 302 ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) 303 ! 304 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab 305 DO jj = 1, ipj 306 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 307 DO ji = 1, Ni_0 308 ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 309 znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) 310 END DO 311 DO ji = Ni_0+1, i0max 312 znorthloc(ji,jj,jk,jl,jf) = HUGEVAL(0.) ! avoid sending uninitialized values (make sure we don't use it) 231 313 END DO 232 314 END DO 233 END DO 234 ! 235 ibuffsize = jpimax * ipj * ipk * ipl * ipf 236 ! 237 ALLOCATE( ztab (jpiglo,ipj,ipk,ipl,ipf ) ) 238 ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 239 ! 240 ! when some processors of the north fold are suppressed, 241 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 242 ! and we need a default definition to 0. 243 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 244 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 315 END DO ; END DO ; END DO 245 316 ! 246 317 ! start waiting time measurement 247 318 IF( ln_timing ) CALL tic_tac(.TRUE.) 248 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_DOUBLE_PRECISION, & 249 & znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr )250 ! 319 #if defined key_mpp_mpi 320 CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 321 #endif 251 322 ! stop waiting time measurement 252 323 IF( ln_timing ) CALL tic_tac(.FALSE.) 253 ! 254 DO jr = 1, ndim_rank_north ! recover the global north array 255 iproc = nrank_north(jr) + 1 256 iilb = nimppt(iproc) 257 ilci = nlcit (iproc) 258 ildi = nldit (iproc) 259 ilei = nleit (iproc) 260 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 261 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 262 DO jf = 1, ipf 263 DO jl = 1, ipl 264 DO jk = 1, ipk 324 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 328 ijnr = 0 329 DO jr = 1, jpni ! recover the global north array 330 iproc = nfproc(jr) 331 impp = nfimpp(jr) 332 ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc 333 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 334 ! 335 SELECT CASE ( kfillmode ) 336 CASE ( jpfillnothing ) ! no filling 337 CASE ( jpfillcopy ) ! filling with inner domain values 338 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 265 339 DO jj = 1, ipj 266 DO ji = ildi, ilei 267 ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr) 340 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 341 DO ji = 1, ipi 342 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 343 ztabglo(ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 268 344 END DO 269 345 END DO 346 END DO ; END DO ; END DO 347 CASE ( jpfillcst ) ! filling with constant value 348 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 349 DO jj = 1, ipj 350 DO ji = 1, ipi 351 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 352 ztabglo(ii1,jj,jk,jl,jf) = pfillval 353 END DO 354 END DO 355 END DO ; END DO ; END DO 356 END SELECT 357 ! 358 ELSE 359 ijnr = ijnr + 1 360 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 361 DO jj = 1, ipj 362 DO ji = 1, ipi 363 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 364 ztabglo(ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr) 365 END DO 270 366 END DO 367 END DO ; END DO ; END DO 368 ENDIF 369 ! 370 END DO ! jpni 371 DEALLOCATE( znorthglo ) 372 ! 373 DO jf = 1, ipf 374 CALL lbc_nfd( ztabglo(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 375 DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity 376 DO jj = 1, nn_hls + 1 377 ij1 = ipj2 - (nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2 378 ztabglo( 1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf) 379 ztabglo(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf) 380 END DO 381 END DO ; END DO 382 END DO 383 ! 384 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN 385 DO jj = 1, nn_hls + 1 386 ij1 = jpj - (nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj 387 ij2 = ipj2 - (nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2 388 DO ji= 1, jpi 389 ii2 = mig(ji) 390 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf) 271 391 END DO 272 392 END DO 273 END DO 274 DO jf = 1, ipf 275 CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 276 END DO 277 ! 278 DO jf = 1, ipf 279 DO jl = 1, ipl 280 DO jk = 1, ipk 281 DO jj = nlcj-ipj+1, nlcj ! Scatter back to ARRAY_IN 282 ij = jj - nlcj + ipj 283 DO ji= 1, nlci 284 ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf) 285 END DO 286 END DO 287 END DO 288 END DO 289 END DO 290 ! 291 ! 292 DEALLOCATE( ztab ) 293 DEALLOCATE( znorthgloio ) 294 ENDIF 295 ! 296 DEALLOCATE( znorthloc ) 393 END DO ; END DO ; END DO 394 ! 395 DEALLOCATE( ztabglo ) 396 ! 397 ENDIF ! l_north_nogather 297 398 ! 298 399 END SUBROUTINE ROUTINE_NFD 299 400 401 #undef PRECISION 402 #undef MPI_TYPE 403 #undef SENDROUTINE 404 #undef RECVROUTINE 300 405 #undef ARRAY_TYPE 301 406 #undef NAT_IN … … 306 411 #undef F_SIZE 307 412 #undef LBC_ARG 413 #undef HUGEVAL -
NEMO/branches/2020/dev_12905_xios_ancil/src/OCE/LBC/mppini.F90
r12377 r13766 8 8 !! 8.0 ! 1998-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions 9 9 !! NEMO 1.0 ! 2004-01 (G. Madec, J.M Molines) F90 : free form , north fold jpni > 1 10 !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add mpp_init_nfdcom11 !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) mpp_init_nfdcom: setup avoiding MPI communication10 !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add init_nfdcom 11 !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) init_nfdcom: setup avoiding MPI communication 12 12 !! 4.0 ! 2016-06 (G. Madec) use domain configuration file instead of bathymetry file 13 13 !! 4.0 ! 2017-06 (J.M. Molines, T. Lovato) merge of mppini and mppini_2 … … 15 15 16 16 !!---------------------------------------------------------------------- 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 !! mpp_init_mask : Read global bathymetric information to facilitate land suppression 19 !! mpp_init_ioipsl : IOIPSL initialization in mpp 20 !! mpp_init_partition: Calculate MPP domain decomposition 21 !! factorise : Calculate the factors of the no. of MPI processes 22 !! mpp_init_nfdcom : Setup for north fold exchanges with explicit point-to-point messaging 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 !! init_ioipsl: IOIPSL initialization in mpp 19 !! init_nfdcom: Setup for north fold exchanges with explicit point-to-point messaging 20 !! init_doloop: set the starting/ending indices of DO-loop used in do_loop_substitute 23 21 !!---------------------------------------------------------------------- 24 22 USE dom_oce ! ocean space and time domain 25 23 USE bdy_oce ! open BounDarY 26 24 ! 27 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges25 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 28 26 USE lib_mpp ! distribued memory computing library 29 27 USE iom ! nemo I/O library … … 34 32 PRIVATE 35 33 36 PUBLIC mpp_init ! called by opa.F90 37 38 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 39 INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit 34 PUBLIC mpp_init ! called by nemogcm.F90 35 PUBLIC mpp_getnum ! called by prtctl 36 PUBLIC mpp_basesplit ! called by prtctl 37 PUBLIC mpp_is_ocean ! called by prtctl 38 39 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 40 INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit 40 41 41 42 !!---------------------------------------------------------------------- … … 61 62 !!---------------------------------------------------------------------- 62 63 ! 64 nn_hls = 1 65 jpiglo = Ni0glo + 2 * nn_hls 66 jpjglo = Nj0glo + 2 * nn_hls 63 67 jpimax = jpiglo 64 68 jpjmax = jpjglo … … 66 70 jpj = jpjglo 67 71 jpk = jpkglo 68 jpim1 = jpi-1 69 jpjm1 = jpj-1 70 jpkm1 = MAX( 1, jpk-1 ) 72 jpim1 = jpi-1 ! inner domain indices 73 jpjm1 = jpj-1 ! " " 74 jpkm1 = MAX( 1, jpk-1 ) ! " " 71 75 jpij = jpi*jpj 72 76 jpni = 1 73 77 jpnj = 1 74 78 jpnij = jpni*jpnj 75 nimpp = 1 !79 nimpp = 1 76 80 njmpp = 1 77 nlci = jpi78 nlcj = jpj79 nldi = 180 nldj = 181 nlei = jpi82 nlej = jpj83 81 nbondi = 2 84 82 nbondj = 2 … … 90 88 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 91 89 ! 90 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) 91 ! 92 92 IF(lwp) THEN 93 93 WRITE(numout,*) … … 98 98 ENDIF 99 99 ! 100 IF( jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) & 101 CALL ctl_stop( 'mpp_init: equality jpni = jpnj = jpnij = 1 is not satisfied', & 102 & 'the domain is lay out for distributed memory computing!' ) 103 ! 100 #if defined key_agrif 101 IF (.NOT.agrif_root()) THEN 102 call agrif_nemo_init() 103 ENDIF 104 #endif 104 105 END SUBROUTINE mpp_init 105 106 … … 130 131 !! njmpp : latitudinal index 131 132 !! narea : number for local area 132 !! nlci : first dimension133 !! nlcj : second dimension134 133 !! nbondi : mark for "east-west local boundary" 135 134 !! nbondj : mark for "north-south local boundary" … … 142 141 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 143 142 INTEGER :: inijmin 144 INTEGER :: i2add145 143 INTEGER :: inum ! local logical unit 146 INTEGER :: idir, ifreq , icont! local integers144 INTEGER :: idir, ifreq ! local integers 147 145 INTEGER :: ii, il1, ili, imil ! - - 148 146 INTEGER :: ij, il2, ilj, ijm1 ! - - … … 157 155 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 158 156 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 159 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, i lci, ibondi, ipproc ! 2D workspace160 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, i lcj, ibondj, ipolj ! - -161 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lei, ildi, iono, ioea ! - -162 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lej, ildj, ioso, iowe ! - -157 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 158 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 159 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 160 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 163 161 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 164 162 NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & … … 168 166 & cn_ice, nn_ice_dta, & 169 167 & ln_vol, nn_volctl, nn_rimwidth 170 NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly168 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 171 169 !!---------------------------------------------------------------------- 172 170 ! … … 181 179 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) 182 180 ! 181 nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0 183 182 IF(lwp) THEN 184 183 WRITE(numout,*) ' Namelist nammpp' … … 190 189 ENDIF 191 190 WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather 191 WRITE(numout,*) ' halo width (applies to both rows and columns) nn_hls = ', nn_hls 192 192 ENDIF 193 193 ! 194 194 IF(lwm) WRITE( numond, nammpp ) 195 195 ! 196 !!!------------------------------------ 197 !!! nn_hls shloud be read in nammpp 198 !!!------------------------------------ 199 jpiglo = Ni0glo + 2 * nn_hls 200 jpjglo = Nj0glo + 2 * nn_hls 201 ! 196 202 ! do we need to take into account bdy_msk? 197 203 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) … … 203 209 IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 204 210 ! 205 IF( ln_listonly ) CALL mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core211 IF( ln_listonly ) CALL bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core 206 212 ! 207 213 ! 1. Dimension arrays for subdomains 208 214 ! ----------------------------------- 209 215 ! 210 ! If dimensions of processor grid weren't specified in the namelist file216 ! If dimensions of processors grid weren't specified in the namelist file 211 217 ! then we calculate them here now that we have our communicator size 212 218 IF(lwp) THEN … … 216 222 ENDIF 217 223 IF( jpni < 1 .OR. jpnj < 1 ) THEN 218 CALL mpp_init_bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes224 CALL bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes 219 225 llauto = .TRUE. 220 226 llbest = .TRUE. 221 227 ELSE 222 228 llauto = .FALSE. 223 CALL mpp_init_bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes229 CALL bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes 224 230 ! largest subdomain size for mpi decoposition jpni*jpnj given in the namelist 225 CALL mpp_bas ic_decomposition(jpni, jpnj, jpimax, jpjmax )226 ! largest subdomain size for mpi decoposition inbi*inbj given by mpp_init_bestpartition227 CALL mpp_bas ic_decomposition(inbi, inbj, iimax, ijmax )231 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax ) 232 ! largest subdomain size for mpi decoposition inbi*inbj given by bestpartition 233 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, inbi, inbj, iimax, ijmax ) 228 234 icnt1 = jpni*jpnj - mppsize ! number of land subdomains that should be removed to use mppsize mpi processes 229 235 IF(lwp) THEN … … 256 262 ! look for land mpi subdomains... 257 263 ALLOCATE( llisoce(jpni,jpnj) ) 258 CALL mpp_i nit_isoce( jpni, jpnj,llisoce )264 CALL mpp_is_ocean( llisoce ) 259 265 inijmin = COUNT( llisoce ) ! number of oce subdomains 260 266 … … 265 271 WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: ' 266 272 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 267 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core273 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 268 274 ENDIF 269 275 … … 289 295 WRITE(numout,*) 290 296 ENDIF 291 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core297 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 292 298 ENDIF 293 299 … … 314 320 9003 FORMAT (a, i5) 315 321 316 IF( numbot /= -1 ) CALL iom_close( numbot ) 317 IF( numbdy /= -1 ) CALL iom_close( numbdy ) 318 319 ALLOCATE( nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) , & 320 & nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , & 321 & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , & 322 & nleit(jpnij) , nlejt(jpnij) , & 322 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 323 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 324 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 325 & nie0all(jpnij) , nje0all(jpnij) , & 323 326 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 324 327 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 325 & iimppt(jpni,jpnj), i lci(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), &326 & ijmppt(jpni,jpnj), i lcj(jpni,jpnj), ibondj(jpni,jpnj),ipolj(jpni,jpnj), &327 & ilei(jpni,jpnj), ildi(jpni,jpnj), iono(jpni,jpnj),ioea(jpni,jpnj), &328 & ilej(jpni,jpnj), ildj(jpni,jpnj), ioso(jpni,jpnj),iowe(jpni,jpnj), &328 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 329 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 330 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 331 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 329 332 & STAT=ierr ) 330 333 CALL mpp_sum( 'mppini', ierr ) … … 333 336 #if defined key_agrif 334 337 IF( .NOT. Agrif_Root() ) THEN ! AGRIF children: specific setting (cf. agrif_user.F90) 335 IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells ) & 336 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells' ) 337 IF( jpjglo /= nbcellsy + 2 + 2*nbghostcells ) & 338 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nbghostcells' ) 339 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' ) 338 CALL agrif_nemo_init() 340 339 ENDIF 341 340 #endif … … 344 343 ! ----------------------------------- 345 344 ! 346 nreci = 2 * nn_hls 347 nrecj = 2 * nn_hls 348 CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ilci, ilcj ) 349 nfiimpp(:,:) = iimppt(:,:) 350 nfilcit(:,:) = ilci(:,:) 345 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 346 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 347 ! 348 !DO jn = 1, jpni 349 ! jproc = ipproc(jn,jpnj) 350 ! ii = iin(jproc+1) 351 ! ij = ijn(jproc+1) 352 ! nfproc(jn) = jproc 353 ! nfimpp(jn) = iimppt(ii,ij) 354 ! nfjpi (jn) = ijpi(ii,ij) 355 !END DO 356 nfproc(:) = ipproc(:,jpnj) 357 nfimpp(:) = iimppt(:,jpnj) 358 nfjpi (:) = ijpi(:,jpnj) 351 359 ! 352 360 IF(lwp) THEN … … 357 365 WRITE(numout,*) ' jpni = ', jpni 358 366 WRITE(numout,*) ' jpnj = ', jpnj 367 WRITE(numout,*) ' jpnij = ', jpnij 359 368 WRITE(numout,*) 360 WRITE(numout,*) ' sum i lci(i,1) = ', sum(ilci(:,1)), ' jpiglo = ', jpiglo361 WRITE(numout,*) ' sum i lcj(1,j) = ', sum(ilcj(1,:)), ' jpjglo = ', jpjglo369 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 370 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 362 371 ENDIF 363 372 … … 374 383 ii = 1 + MOD(iarea0,jpni) 375 384 ij = 1 + iarea0/jpni 376 ili = i lci(ii,ij)377 ilj = i lcj(ii,ij)385 ili = ijpi(ii,ij) 386 ilj = ijpj(ii,ij) 378 387 ibondi(ii,ij) = 0 ! default: has e-w neighbours 379 388 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour … … 390 399 ioea(ii,ij) = iarea0 + 1 391 400 iono(ii,ij) = iarea0 + jpni 392 i ldi(ii,ij) = 1 + nn_hls393 i lei(ii,ij) = ili - nn_hls394 i ldj(ii,ij) = 1 + nn_hls395 i lej(ii,ij) = ilj - nn_hls401 iis0(ii,ij) = 1 + nn_hls 402 iie0(ii,ij) = ili - nn_hls 403 ijs0(ii,ij) = 1 + nn_hls 404 ije0(ii,ij) = ilj - nn_hls 396 405 397 406 ! East-West periodicity: change ibondi, ioea, iowe … … 431 440 ! ---------------------------- 432 441 ! 433 ! specify which subdomains are oce subdomains; other are land subdomains434 ipproc(:,:) = -1435 icont = -1436 DO jarea = 1, jpni*jpnj437 iarea0 = jarea - 1438 ii = 1 + MOD(iarea0,jpni)439 ij = 1 + iarea0/jpni440 IF( llisoce(ii,ij) ) THEN441 icont = icont + 1442 ipproc(ii,ij) = icont443 iin(icont+1) = ii444 ijn(icont+1) = ij445 ENDIF446 END DO447 ! if needed add some land subdomains to reach jpnij active subdomains448 i2add = jpnij - inijmin449 DO jarea = 1, jpni*jpnj450 iarea0 = jarea - 1451 ii = 1 + MOD(iarea0,jpni)452 ij = 1 + iarea0/jpni453 IF( .NOT. llisoce(ii,ij) .AND. i2add > 0 ) THEN454 icont = icont + 1455 ipproc(ii,ij) = icont456 iin(icont+1) = ii457 ijn(icont+1) = ij458 i2add = i2add - 1459 ENDIF460 END DO461 nfipproc(:,:) = ipproc(:,:)462 463 442 ! neighbour treatment: change ibondi, ibondj if next to a land zone 464 443 DO jarea = 1, jpni*jpnj … … 499 478 ENDIF 500 479 END DO 501 502 ! Update il[de][ij] according to modified ibond[ij]503 ! ----------------------504 DO jproc = 1, jpnij505 ii = iin(jproc)506 ij = ijn(jproc)507 IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) = 1508 IF( ibondi(ii,ij) == 1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ilci(ii,ij)509 IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) = 1510 IF( ibondj(ii,ij) == 1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilcj(ii,ij)511 END DO512 480 513 481 ! 5. Subdomain print … … 522 490 DO jj = jpnj, 1, -1 523 491 WRITE(numout,9403) (' ',ji=il1,il2-1) 524 WRITE(numout,9402) jj, (i lci(ji,jj),ilcj(ji,jj),ji=il1,il2)492 WRITE(numout,9402) jj, (ijpi(ji,jj),ijpj(ji,jj),ji=il1,il2) 525 493 WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2) 526 494 WRITE(numout,9403) (' ',ji=il1,il2-1) … … 579 547 noea = ii_noea(narea) 580 548 nono = ii_nono(narea) 581 nlci = ilci(ii,ij)582 nldi = ildi(ii,ij)583 nlei = ilei(ii,ij)584 nlcj = ilcj(ii,ij)585 nldj = ildj(ii,ij)586 nlej = ilej(ii,ij)549 jpi = ijpi(ii,ij) 550 !!$ Nis0 = iis0(ii,ij) 551 !!$ Nie0 = iie0(ii,ij) 552 jpj = ijpj(ii,ij) 553 !!$ Njs0 = ijs0(ii,ij) 554 !!$ Nje0 = ije0(ii,ij) 587 555 nbondi = ibondi(ii,ij) 588 556 nbondj = ibondj(ii,ij) 589 557 nimpp = iimppt(ii,ij) 590 558 njmpp = ijmppt(ii,ij) 591 jpi = nlci 592 jpj = nlcj 593 jpk = jpkglo ! third dim 594 #if defined key_agrif 595 ! simple trick to use same vertical grid as parent but different number of levels: 596 ! Save maximum number of levels in jpkglo, then define all vertical grids with this number. 597 ! Suppress once vertical online interpolation is ok 598 !!$ IF(.NOT.Agrif_Root()) jpkglo = Agrif_Parent( jpkglo ) 599 #endif 600 jpim1 = jpi-1 ! inner domain indices 601 jpjm1 = jpj-1 ! " " 602 jpkm1 = MAX( 1, jpk-1 ) ! " " 603 jpij = jpi*jpj ! jpi x j 559 jpk = jpkglo ! third dim 560 ! 561 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 562 ! 563 jpim1 = jpi-1 ! inner domain indices 564 jpjm1 = jpj-1 ! " " 565 jpkm1 = MAX( 1, jpk-1 ) ! " " 566 jpij = jpi*jpj ! jpi x j 604 567 DO jproc = 1, jpnij 605 568 ii = iin(jproc) 606 569 ij = ijn(jproc) 607 nlcit(jproc) = ilci(ii,ij)608 n ldit(jproc) = ildi(ii,ij)609 n leit(jproc) = ilei(ii,ij)610 nlcjt(jproc) = ilcj(ii,ij)611 n ldjt(jproc) = ildj(ii,ij)612 n lejt(jproc) = ilej(ii,ij)570 jpiall (jproc) = ijpi(ii,ij) 571 nis0all(jproc) = iis0(ii,ij) 572 nie0all(jproc) = iie0(ii,ij) 573 jpjall (jproc) = ijpj(ii,ij) 574 njs0all(jproc) = ijs0(ii,ij) 575 nje0all(jproc) = ije0(ii,ij) 613 576 ibonit(jproc) = ibondi(ii,ij) 614 577 ibonjt(jproc) = ibondj(ii,ij) … … 624 587 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 625 588 & ' ( local: ',narea,jpi,jpj,' )' 626 WRITE(inum,'(a)') 'nproc nlci nlcj nldi nldj nlei nlejnimp njmp nono noso nowe noea nbondi nbondj '589 WRITE(inum,'(a)') 'nproc jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 627 590 628 591 DO jproc = 1, jpnij 629 WRITE(inum,'(13i5,2i7)') jproc-1, nlcit (jproc), nlcjt(jproc), &630 & n ldit (jproc), nldjt(jproc), &631 & n leit (jproc), nlejt(jproc), &592 WRITE(inum,'(13i5,2i7)') jproc-1, jpiall(jproc), jpjall(jproc), & 593 & nis0all(jproc), njs0all(jproc), & 594 & nie0all(jproc), nje0all(jproc), & 632 595 & nimppt (jproc), njmppt (jproc), & 633 596 & ii_nono(jproc), ii_noso(jproc), & … … 663 626 WRITE(numout,*) ' l_Iperio = ', l_Iperio 664 627 WRITE(numout,*) ' l_Jperio = ', l_Jperio 665 WRITE(numout,*) ' nlci = ', nlci666 WRITE(numout,*) ' nlcj = ', nlcj667 628 WRITE(numout,*) ' nimpp = ', nimpp 668 629 WRITE(numout,*) ' njmpp = ', njmpp 669 WRITE(numout,*) ' nreci = ', nreci670 WRITE(numout,*) ' nrecj = ', nrecj671 WRITE(numout,*) ' nn_hls = ', nn_hls672 630 ENDIF 673 631 … … 691 649 ENDIF 692 650 ! 693 CALL mpp_init_ioipsl ! Prepare NetCDF output file (if necessary)651 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 694 652 ! 695 653 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 696 CALL mpp_init_nfdcom ! northfold neighbour lists654 CALL init_nfdcom ! northfold neighbour lists 697 655 IF (llwrtlay) THEN 698 656 WRITE(inum,*) 699 657 WRITE(inum,*) 700 658 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 701 WRITE(inum,*) 'nfsloop : ', nfsloop702 WRITE(inum,*) 'nfeloop : ', nfeloop703 659 WRITE(inum,*) 'nsndto : ', nsndto 704 660 WRITE(inum,*) 'isendto : ', isendto … … 710 666 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 711 667 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 712 & i lci, ilcj, ilei, ilej, ildi, ildj, &668 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 713 669 & iono, ioea, ioso, iowe, llisoce) 714 670 ! 715 671 END SUBROUTINE mpp_init 716 672 717 718 SUBROUTINE mpp_basic_decomposition( knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) 719 !!---------------------------------------------------------------------- 720 !! *** ROUTINE mpp_basic_decomposition *** 673 #endif 674 675 SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) 676 !!---------------------------------------------------------------------- 677 !! *** ROUTINE mpp_basesplit *** 721 678 !! 722 679 !! ** Purpose : Lay out the global domain over processors. … … 730 687 !! klcj : second dimension 731 688 !!---------------------------------------------------------------------- 689 INTEGER, INTENT(in ) :: kiglo, kjglo 690 INTEGER, INTENT(in ) :: khls 732 691 INTEGER, INTENT(in ) :: knbi, knbj 733 692 INTEGER, INTENT( out) :: kimax, kjmax … … 736 695 ! 737 696 INTEGER :: ji, jj 697 INTEGER :: i2hls 738 698 INTEGER :: iresti, irestj, irm, ijpjmin 739 INTEGER :: ireci, irecj740 !!----------------------------------------------------------------------699 !!---------------------------------------------------------------------- 700 i2hls = 2*khls 741 701 ! 742 702 #if defined key_nemocice_decomp 743 kimax = ( nx_global+2- 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.744 kjmax = ( ny_global+2- 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.703 kimax = ( nx_global+2-i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 704 kjmax = ( ny_global+2-i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 745 705 #else 746 kimax = ( jpiglo - 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.747 kjmax = ( jpjglo - 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.706 kimax = ( kiglo - i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 707 kjmax = ( kjglo - i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 748 708 #endif 749 709 IF( .NOT. PRESENT(kimppt) ) RETURN … … 752 712 ! ----------------------------------- 753 713 ! Computation of local domain sizes klci() klcj() 754 ! These dimensions depend on global sizes knbi,knbj and jpiglo,jpjglo714 ! These dimensions depend on global sizes knbi,knbj and kiglo,kjglo 755 715 ! The subdomains are squares lesser than or equal to the global 756 716 ! dimensions divided by the number of processors minus the overlap array. 757 717 ! 758 ireci = 2 * nn_hls 759 irecj = 2 * nn_hls 760 iresti = 1 + MOD( jpiglo - ireci -1 , knbi ) 761 irestj = 1 + MOD( jpjglo - irecj -1 , knbj ) 718 iresti = 1 + MOD( kiglo - i2hls - 1 , knbi ) 719 irestj = 1 + MOD( kjglo - i2hls - 1 , knbj ) 762 720 ! 763 721 ! Need to use kimax and kjmax here since jpi and jpj not yet defined 764 722 #if defined key_nemocice_decomp 765 723 ! Change padding to be consistent with CICE 766 klci(1:knbi-1 ,:) = kimax767 klci( knbi ,:) = jpiglo - (knbi - 1) * (kimax - nreci)768 klcj(: ,1:knbj-1) = kjmax769 klcj(: , knbj) = jpjglo - (knbj - 1) * (kjmax - nrecj)724 klci(1:knbi-1,: ) = kimax 725 klci( knbi ,: ) = kiglo - (knbi - 1) * (kimax - i2hls) 726 klcj(: ,1:knbj-1) = kjmax 727 klcj(: , knbj ) = kjglo - (knbj - 1) * (kjmax - i2hls) 770 728 #else 771 729 klci(1:iresti ,:) = kimax 772 730 klci(iresti+1:knbi ,:) = kimax-1 773 IF( MINVAL(klci) < 3) THEN774 WRITE(ctmp1,*) ' mpp_bas ic_decomposition: minimum value of jpi must be >= 3'731 IF( MINVAL(klci) < 2*i2hls ) THEN 732 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpi must be >= ', 2*i2hls 775 733 WRITE(ctmp2,*) ' We have ', MINVAL(klci) 776 734 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 778 736 IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN 779 737 ! minimize the size of the last row to compensate for the north pole folding coast 780 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 5 ! V and F folding involves line jpj-3 that must not be south boundary 781 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 4 ! V and F folding involves line jpj-2 that must not be south boundary 782 irm = knbj - irestj ! total number of lines to be removed 783 klcj(:, knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 784 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 785 irestj = knbj - 1 - irm 786 klcj(:, 1:irestj) = kjmax 738 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos 739 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos 740 irm = knbj - irestj ! total number of lines to be removed 741 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 742 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 743 irestj = knbj - 1 - irm 787 744 klcj(:, irestj+1:knbj-1) = kjmax-1 788 745 ELSE 789 ijpjmin = 3 790 klcj(:, 1:irestj) = kjmax 791 klcj(:, irestj+1:knbj) = kjmax-1 792 ENDIF 793 IF( MINVAL(klcj) < ijpjmin ) THEN 794 WRITE(ctmp1,*) ' mpp_basic_decomposition: minimum value of jpj must be >= ', ijpjmin 746 klcj(:, irestj+1:knbj ) = kjmax-1 747 ENDIF 748 klcj(:,1:irestj) = kjmax 749 IF( MINVAL(klcj) < 2*i2hls ) THEN 750 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpj must be >= ', 2*i2hls 795 751 WRITE(ctmp2,*) ' We have ', MINVAL(klcj) 796 752 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 806 762 DO jj = 1, knbj 807 763 DO ji = 2, knbi 808 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i reci764 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i2hls 809 765 END DO 810 766 END DO … … 814 770 DO jj = 2, knbj 815 771 DO ji = 1, knbi 816 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i recj772 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i2hls 817 773 END DO 818 774 END DO 819 775 ENDIF 820 776 821 END SUBROUTINE mpp_bas ic_decomposition822 823 824 SUBROUTINE mpp_init_bestpartition( knbij, knbi, knbj, knbcnt, ldlist )825 !!---------------------------------------------------------------------- 826 !! *** ROUTINE mpp_init_bestpartition ***777 END SUBROUTINE mpp_basesplit 778 779 780 SUBROUTINE bestpartition( knbij, knbi, knbj, knbcnt, ldlist ) 781 !!---------------------------------------------------------------------- 782 !! *** ROUTINE bestpartition *** 827 783 !! 828 784 !! ** Purpose : … … 830 786 !! ** Method : 831 787 !!---------------------------------------------------------------------- 832 INTEGER, INTENT(in ) :: knbij ! total number if subdomains(knbi*knbj)788 INTEGER, INTENT(in ) :: knbij ! total number of subdomains (knbi*knbj) 833 789 INTEGER, OPTIONAL, INTENT( out) :: knbi, knbj ! number if subdomains along i and j (knbi and knbj) 834 790 INTEGER, OPTIONAL, INTENT( out) :: knbcnt ! number of land subdomains … … 838 794 INTEGER :: iszitst, iszjtst 839 795 INTEGER :: isziref, iszjref 796 INTEGER :: iszimin, iszjmin 840 797 INTEGER :: inbij, iszij 841 798 INTEGER :: inbimax, inbjmax, inbijmax, inbijold … … 866 823 inbimax = 0 867 824 inbjmax = 0 868 isziref = jpiglo*jpjglo+1 825 isziref = jpiglo*jpjglo+1 ! define a value that is larger than the largest possible 869 826 iszjref = jpiglo*jpjglo+1 827 ! 828 iszimin = 4*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 829 iszjmin = 4*nn_hls 830 IF( jperio == 3 .OR. jperio == 4 ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos 831 IF( jperio == 5 .OR. jperio == 6 ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos 870 832 ! 871 833 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 875 837 iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 876 838 #else 877 iszitst = ( jpiglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls839 iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain i-size 878 840 #endif 879 IF( iszitst < isziref ) THEN841 IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN 880 842 isziref = iszitst 881 843 inbimax = inbimax + 1 … … 886 848 iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 887 849 #else 888 iszjtst = ( jpjglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls850 iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain j-size 889 851 #endif 890 IF( iszjtst < iszjref ) THEN852 IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN 891 853 iszjref = iszjtst 892 854 inbjmax = inbjmax + 1 … … 926 888 iszij1(:) = iszi1(:) * iszj1(:) 927 889 928 ! if ther ris no land and no print890 ! if there is no land and no print 929 891 IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1 ) THEN 930 892 ! get the smaller partition which gives the smallest subdomain size … … 945 907 ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results 946 908 IF ( iszij1(ii) < iszij ) THEN 909 ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1) ! select the smaller perimeter if multiple min 947 910 isz0 = isz0 + 1 948 911 indexok(isz0) = ii … … 974 937 ji = isz0 ! initialization with the largest value 975 938 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 976 CALL mpp_i nit_isoce( inbi0(ji), inbj0(ji), llisoce )! Warning: must be call by all cores (call mpp_sum)939 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 977 940 inbijold = COUNT(llisoce) 978 941 DEALLOCATE( llisoce ) 979 942 DO ji =isz0-1,1,-1 980 943 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 981 CALL mpp_i nit_isoce( inbi0(ji), inbj0(ji), llisoce )! Warning: must be call by all cores (call mpp_sum)944 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 982 945 inbij = COUNT(llisoce) 983 946 DEALLOCATE( llisoce ) … … 1005 968 ii = ii -1 1006 969 ALLOCATE( llisoce(inbi0(ii), inbj0(ii)) ) 1007 CALL mpp_i nit_isoce( inbi0(ii), inbj0(ii),llisoce ) ! must be done by all core970 CALL mpp_is_ocean( llisoce ) ! must be done by all core 1008 971 inbij = COUNT(llisoce) 1009 972 DEALLOCATE( llisoce ) … … 1014 977 DEALLOCATE( inbi0, inbj0 ) 1015 978 ! 1016 END SUBROUTINE mpp_init_bestpartition979 END SUBROUTINE bestpartition 1017 980 1018 981 … … 1023 986 !! ** Purpose : the the proportion of land points in the surface land-sea mask 1024 987 !! 1025 !! ** Method : read iproc strips (of length jpiglo) of the land-sea mask988 !! ** Method : read iproc strips (of length Ni0glo) of the land-sea mask 1026 989 !!---------------------------------------------------------------------- 1027 990 REAL(wp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1) … … 1040 1003 1041 1004 ! number of processes reading the bathymetry file 1042 iproc = MINVAL( (/mppsize, jpjglo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time1005 iproc = MINVAL( (/mppsize, Nj0glo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time 1043 1006 1044 1007 ! we want to read iproc strips of the land-sea mask. -> pick up iproc processes every idiv processes starting at 1 … … 1050 1013 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < iproc ) THEN ! beware idiv can be = to 1 1051 1014 ! 1052 ijsz = jpjglo / iproc ! width of the stripe to read1053 IF( iarea < MOD( jpjglo,iproc) ) ijsz = ijsz + 11054 ijstr = iarea*( jpjglo/iproc) + MIN(iarea, MOD(jpjglo,iproc)) + 1 ! starting j position of the reading1015 ijsz = Nj0glo / iproc ! width of the stripe to read 1016 IF( iarea < MOD(Nj0glo,iproc) ) ijsz = ijsz + 1 1017 ijstr = iarea*(Nj0glo/iproc) + MIN(iarea, MOD(Nj0glo,iproc)) + 1 ! starting j position of the reading 1055 1018 ! 1056 ALLOCATE( lloce( jpiglo, ijsz) ) ! allocate the strip1057 CALL mpp_init_readbot_strip( ijstr, ijsz, lloce )1019 ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip 1020 CALL readbot_strip( ijstr, ijsz, lloce ) 1058 1021 inboce = COUNT(lloce) ! number of ocean point in the stripe 1059 1022 DEALLOCATE(lloce) … … 1064 1027 CALL mpp_sum( 'mppini', inboce ) ! total number of ocean points over the global domain 1065 1028 ! 1066 propland = REAL( jpiglo*jpjglo - inboce, wp ) / REAL( jpiglo*jpjglo, wp )1029 propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp ) 1067 1030 ! 1068 1031 END SUBROUTINE mpp_init_landprop 1069 1032 1070 1033 1071 SUBROUTINE mpp_init_isoce( knbi, knbj, ldisoce ) 1072 !!---------------------------------------------------------------------- 1073 !! *** ROUTINE mpp_init_nboce *** 1074 !! 1075 !! ** Purpose : check for a mpi domain decomposition knbi x knbj which 1076 !! subdomains contain at least 1 ocean point 1077 !! 1078 !! ** Method : read knbj strips (of length jpiglo) of the land-sea mask 1079 !!---------------------------------------------------------------------- 1080 INTEGER, INTENT(in ) :: knbi, knbj ! domain decomposition 1081 LOGICAL, DIMENSION(knbi,knbj), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1082 ! 1083 INTEGER, DIMENSION(knbi,knbj) :: inboce ! number oce oce pint in each mpi subdomain 1084 INTEGER, DIMENSION(knbi*knbj) :: inboce_1d 1034 SUBROUTINE mpp_is_ocean( ldisoce ) 1035 !!---------------------------------------------------------------------- 1036 !! *** ROUTINE mpp_is_ocean *** 1037 !! 1038 !! ** Purpose : Check for a mpi domain decomposition inbi x inbj which 1039 !! subdomains, including 1 halo (even if nn_hls>1), contain 1040 !! at least 1 ocean point. 1041 !! We must indeed ensure that each subdomain that is a neighbour 1042 !! of a land subdomain as only land points on its boundary 1043 !! (inside the inner subdomain) with the land subdomain. 1044 !! This is needed to get the proper bondary conditions on 1045 !! a subdomain with a closed boundary. 1046 !! 1047 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1048 !!---------------------------------------------------------------------- 1049 LOGICAL, DIMENSION(:,:), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1050 ! 1085 1051 INTEGER :: idiv, iimax, ijmax, iarea 1052 INTEGER :: inbi, inbj, inx, iny, inry, isty 1086 1053 INTEGER :: ji, jn 1087 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1088 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci 1089 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj 1054 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: inboce ! number oce oce pint in each mpi subdomain 1055 INTEGER, ALLOCATABLE, DIMENSION(: ) :: inboce_1d 1056 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi 1057 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj 1058 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1090 1059 !!---------------------------------------------------------------------- 1091 1060 ! do nothing if there is no land-sea mask … … 1094 1063 RETURN 1095 1064 ENDIF 1096 1097 ! we want to read knbj strips of the land-sea mask. -> pick up knbj processes every idiv processes starting at 1 1098 IF ( knbj == 1 ) THEN ; idiv = mppsize 1099 ELSE IF ( mppsize < knbj ) THEN ; idiv = 1 1100 ELSE ; idiv = ( mppsize - 1 ) / ( knbj - 1 ) 1101 ENDIF 1065 ! 1066 inbi = SIZE( ldisoce, dim = 1 ) 1067 inbj = SIZE( ldisoce, dim = 2 ) 1068 ! 1069 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 1070 IF ( inbj == 1 ) THEN ; idiv = mppsize 1071 ELSE IF ( mppsize < inbj ) THEN ; idiv = 1 1072 ELSE ; idiv = ( mppsize - 1 ) / ( inbj - 1 ) 1073 ENDIF 1074 ! 1075 ALLOCATE( inboce(inbi,inbj), inboce_1d(inbi*inbj) ) 1102 1076 inboce(:,:) = 0 ! default no ocean point found 1103 1104 DO jn = 0, ( knbj-1)/mppsize ! if mppsize < knbj : more strips than mpi processes (because of potential land domains)1077 ! 1078 DO jn = 0, (inbj-1)/mppsize ! if mppsize < inbj : more strips than mpi processes (because of potential land domains) 1105 1079 ! 1106 iarea = (narea-1)/idiv + jn * mppsize ! involed process number (starting counting at 0)1107 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < knbj ) THEN! beware idiv can be = to 11080 iarea = (narea-1)/idiv + jn * mppsize + 1 ! involed process number (starting counting at 1) 1081 IF( MOD( narea-1, idiv ) == 0 .AND. iarea <= inbj ) THEN ! beware idiv can be = to 1 1108 1082 ! 1109 ALLOCATE( iimppt( knbi,knbj), ijmppt(knbi,knbj), ilci(knbi,knbj), ilcj(knbi,knbj) )1110 CALL mpp_bas ic_decomposition( knbi, knbj, iimax, ijmax, iimppt, ijmppt, ilci, ilcj )1083 ALLOCATE( iimppt(inbi,inbj), ijmppt(inbi,inbj), ijpi(inbi,inbj), ijpj(inbi,inbj) ) 1084 CALL mpp_basesplit( Ni0glo, Nj0glo, 0, inbi, inbj, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) 1111 1085 ! 1112 ALLOCATE( lloce(jpiglo, ilcj(1,iarea+1)) ) ! allocate the strip 1113 CALL mpp_init_readbot_strip( ijmppt(1,iarea+1), ilcj(1,iarea+1), lloce ) ! read the strip 1114 DO ji = 1, knbi 1115 inboce(ji,iarea+1) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ilci(ji,1)-1,:) ) ! number of ocean point in subdomain 1086 inx = Ni0glo + 2 ; iny = ijpj(1,iarea) + 2 ! strip size + 1 halo on each direction (even if nn_hls>1) 1087 ALLOCATE( lloce(inx, iny) ) ! allocate the strip 1088 inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction 1089 isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? 1090 CALL readbot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip 1091 ! 1092 IF( iarea == 1 ) THEN ! the first line was not read 1093 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1094 CALL readbot_strip( Nj0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce 1095 ELSE 1096 lloce(2:inx-1, 1) = .FALSE. ! closed boundary 1097 ENDIF 1098 ENDIF 1099 IF( iarea == inbj ) THEN ! the last line was not read 1100 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1101 CALL readbot_strip( 1, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce 1102 ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN ! north-pole folding T-pivot, T-point 1103 lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) 1104 DO ji = 3,inx-1 1105 lloce(ji,iny ) = lloce(inx-ji+2,iny-2) ! ok, we have at least 3 lines 1106 END DO 1107 DO ji = inx/2+2,inx-1 1108 lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 1109 END DO 1110 ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN ! north-pole folding F-pivot, T-point, 1 halo 1111 lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) 1112 lloce(inx -1,iny-1) = lloce(2 ,iny-1) 1113 DO ji = 2,inx-1 1114 lloce(ji,iny) = lloce(inx-ji+1,iny-1) 1115 END DO 1116 ELSE ! closed boundary 1117 lloce(2:inx-1,iny) = .FALSE. 1118 ENDIF 1119 ENDIF 1120 ! ! first and last column were not read 1121 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 1122 lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity 1123 ELSE 1124 lloce(1,:) = .FALSE. ; lloce(inx,:) = .FALSE. ! closed boundary 1125 ENDIF 1126 ! 1127 DO ji = 1, inbi 1128 inboce(ji,iarea) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ijpi(ji,1)+1,:) ) ! lloce as 2 points more than Ni0glo 1116 1129 END DO 1117 1130 ! 1118 1131 DEALLOCATE(lloce) 1119 DEALLOCATE(iimppt, ijmppt, i lci, ilcj)1132 DEALLOCATE(iimppt, ijmppt, ijpi, ijpj) 1120 1133 ! 1121 1134 ENDIF 1122 1135 END DO 1123 1136 1124 inboce_1d = RESHAPE(inboce, (/ knbi*knbj /))1137 inboce_1d = RESHAPE(inboce, (/ inbi*inbj /)) 1125 1138 CALL mpp_sum( 'mppini', inboce_1d ) 1126 inboce = RESHAPE(inboce_1d, (/ knbi, knbj/))1139 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1127 1140 ldisoce(:,:) = inboce(:,:) /= 0 1128 ! 1129 END SUBROUTINE mpp_init_isoce 1141 DEALLOCATE(inboce, inboce_1d) 1142 ! 1143 END SUBROUTINE mpp_is_ocean 1130 1144 1131 1145 1132 SUBROUTINE mpp_init_readbot_strip( kjstr, kjcnt, ldoce )1133 !!---------------------------------------------------------------------- 1134 !! *** ROUTINE mpp_init_readbot_strip ***1146 SUBROUTINE readbot_strip( kjstr, kjcnt, ldoce ) 1147 !!---------------------------------------------------------------------- 1148 !! *** ROUTINE readbot_strip *** 1135 1149 !! 1136 1150 !! ** Purpose : Read relevant bathymetric information in order to … … 1138 1152 !! of land domains, in an mpp computation. 1139 1153 !! 1140 !! ** Method : read stipe of size ( jpiglo,...)1141 !!---------------------------------------------------------------------- 1142 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading1143 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read1144 LOGICAL, DIMENSION( jpiglo,kjcnt), INTENT( out) ::ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean1154 !! ** Method : read stipe of size (Ni0glo,...) 1155 !!---------------------------------------------------------------------- 1156 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading 1157 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read 1158 LOGICAL, DIMENSION(Ni0glo,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean 1145 1159 ! 1146 1160 INTEGER :: inumsave ! local logical unit 1147 REAL(wp), DIMENSION( jpiglo,kjcnt) :: zbot, zbdy1161 REAL(wp), DIMENSION(Ni0glo,kjcnt) :: zbot, zbdy 1148 1162 !!---------------------------------------------------------------------- 1149 1163 ! 1150 1164 inumsave = numout ; numout = numnul ! redirect all print to /dev/null 1151 1165 ! 1152 IF( numbot /= -1 ) THEN 1153 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/ jpiglo, kjcnt/) )1166 IF( numbot /= -1 ) THEN 1167 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1154 1168 ELSE 1155 zbot(:,:) = 1. 1156 ENDIF 1157 1158 IF( numbdy /= -1 ) THEN! Adjust with bdy_msk if it exists1159 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/jpiglo, kjcnt/) )1169 zbot(:,:) = 1._wp ! put a non-null value 1170 ENDIF 1171 ! 1172 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists 1173 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1160 1174 zbot(:,:) = zbot(:,:) * zbdy(:,:) 1161 1175 ENDIF 1162 1176 ! 1163 ldoce(:,:) = zbot(:,:) > 0. 1177 ldoce(:,:) = zbot(:,:) > 0._wp 1164 1178 numout = inumsave 1165 1179 ! 1166 END SUBROUTINE mpp_init_readbot_strip 1167 1168 1169 SUBROUTINE mpp_init_ioipsl 1170 !!---------------------------------------------------------------------- 1171 !! *** ROUTINE mpp_init_ioipsl *** 1180 END SUBROUTINE readbot_strip 1181 1182 1183 SUBROUTINE mpp_getnum( ldisoce, kproc, kipos, kjpos ) 1184 !!---------------------------------------------------------------------- 1185 !! *** ROUTINE mpp_getnum *** 1186 !! 1187 !! ** Purpose : give a number to each MPI subdomains (starting at 0) 1188 !! 1189 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1190 !!---------------------------------------------------------------------- 1191 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldisoce ! F if land process 1192 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0) 1193 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1194 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) 1195 ! 1196 INTEGER :: ii, ij, jarea, iarea0 1197 INTEGER :: icont, i2add , ini, inj, inij 1198 !!---------------------------------------------------------------------- 1199 ! 1200 ini = SIZE(ldisoce, dim = 1) 1201 inj = SIZE(ldisoce, dim = 2) 1202 inij = SIZE(kipos) 1203 ! 1204 ! specify which subdomains are oce subdomains; other are land subdomains 1205 kproc(:,:) = -1 1206 icont = -1 1207 DO jarea = 1, ini*inj 1208 iarea0 = jarea - 1 1209 ii = 1 + MOD(iarea0,ini) 1210 ij = 1 + iarea0/ini 1211 IF( ldisoce(ii,ij) ) THEN 1212 icont = icont + 1 1213 kproc(ii,ij) = icont 1214 kipos(icont+1) = ii 1215 kjpos(icont+1) = ij 1216 ENDIF 1217 END DO 1218 ! if needed add some land subdomains to reach inij active subdomains 1219 i2add = inij - COUNT( ldisoce ) 1220 DO jarea = 1, ini*inj 1221 iarea0 = jarea - 1 1222 ii = 1 + MOD(iarea0,ini) 1223 ij = 1 + iarea0/ini 1224 IF( .NOT. ldisoce(ii,ij) .AND. i2add > 0 ) THEN 1225 icont = icont + 1 1226 kproc(ii,ij) = icont 1227 kipos(icont+1) = ii 1228 kjpos(icont+1) = ij 1229 i2add = i2add - 1 1230 ENDIF 1231 END DO 1232 ! 1233 END SUBROUTINE mpp_getnum 1234 1235 1236 SUBROUTINE init_ioipsl 1237 !!---------------------------------------------------------------------- 1238 !! *** ROUTINE init_ioipsl *** 1172 1239 !! 1173 1240 !! ** Purpose : … … 1186 1253 ! Set idompar values equivalent to the jpdom_local_noextra definition 1187 1254 ! used in IOM. This works even if jpnij .ne. jpni*jpnj. 1188 iglo(1) = jpiglo 1189 iglo(2) = jpjglo 1190 iloc(1) = nlci 1191 iloc(2) = nlcj 1192 iabsf(1) = nimppt(narea) 1193 iabsf(2) = njmppt(narea) 1255 iglo( :) = (/ Ni0glo, Nj0glo /) 1256 iloc( :) = (/ Ni_0 , Nj_0 /) 1257 iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig0(Nis0) but mig0 is not yet defined! 1194 1258 iabsl(:) = iabsf(:) + iloc(:) - 1 1195 ihals(1) = nldi - 1 1196 ihals(2) = nldj - 1 1197 ihale(1) = nlci - nlei 1198 ihale(2) = nlcj - nlej 1199 idid(1) = 1 1200 idid(2) = 2 1259 ihals(:) = (/ 0 , 0 /) 1260 ihale(:) = (/ 0 , 0 /) 1261 idid( :) = (/ 1 , 2 /) 1201 1262 1202 1263 IF(lwp) THEN 1203 1264 WRITE(numout,*) 1204 WRITE(numout,*) 'mpp _init_ioipsl : iloc = ', iloc (1), iloc (2)1205 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf (1), iabsf(2)1206 WRITE(numout,*) ' ihals = ', ihals (1), ihals(2)1207 WRITE(numout,*) ' ihale = ', ihale (1), ihale(2)1265 WRITE(numout,*) 'mpp init_ioipsl : iloc = ', iloc 1266 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf 1267 WRITE(numout,*) ' ihals = ', ihals 1268 WRITE(numout,*) ' ihale = ', ihale 1208 1269 ENDIF 1209 1270 ! 1210 1271 CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) 1211 1272 ! 1212 END SUBROUTINE mpp_init_ioipsl1213 1214 1215 SUBROUTINE mpp_init_nfdcom1216 !!---------------------------------------------------------------------- 1217 !! *** ROUTINE mpp_init_nfdcom ***1273 END SUBROUTINE init_ioipsl 1274 1275 1276 SUBROUTINE init_nfdcom 1277 !!---------------------------------------------------------------------- 1278 !! *** ROUTINE init_nfdcom *** 1218 1279 !! ** Purpose : Setup for north fold exchanges with explicit 1219 1280 !! point-to-point messaging … … 1225 1286 !!---------------------------------------------------------------------- 1226 1287 INTEGER :: sxM, dxM, sxT, dxT, jn 1227 INTEGER :: njmppmax 1228 !!---------------------------------------------------------------------- 1229 ! 1230 njmppmax = MAXVAL( njmppt ) 1288 !!---------------------------------------------------------------------- 1231 1289 ! 1232 1290 !initializes the north-fold communication variables … … 1234 1292 nsndto = 0 1235 1293 ! 1236 IF ( njmpp == njmppmax) THEN ! if I am a process in the north1294 IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north 1237 1295 ! 1238 1296 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1239 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 11297 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1240 1298 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1241 1299 dxM = jpiglo - nimppt(narea) + 2 … … 1246 1304 DO jn = 1, jpni 1247 1305 ! 1248 sxT = nfi impp(jn, jpnj)! sxT = 1st point (in the global domain) of the jn process1249 dxT = nfi impp(jn, jpnj) + nfilcit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process1306 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1307 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1250 1308 ! 1251 1309 IF ( sxT < sxM .AND. sxM < dxT ) THEN … … 1261 1319 ! 1262 1320 END DO 1263 nfsloop = 11264 nfeloop = nlci1265 DO jn = 2,jpni-11266 IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN1267 IF( nfipproc(jn-1,jpnj) == -1 ) nfsloop = nldi1268 IF( nfipproc(jn+1,jpnj) == -1 ) nfeloop = nlei1269 ENDIF1270 END DO1271 1321 ! 1272 1322 ENDIF 1273 1323 l_north_nogather = .TRUE. 1274 1324 ! 1275 END SUBROUTINE mpp_init_nfdcom 1276 1277 1278 #endif 1279 1325 END SUBROUTINE init_nfdcom 1326 1327 1328 SUBROUTINE init_doloop 1329 !!---------------------------------------------------------------------- 1330 !! *** ROUTINE init_doloop *** 1331 !! 1332 !! ** Purpose : set the starting/ending indices of DO-loop 1333 !! These indices are used in do_loop_substitute.h90 1334 !!---------------------------------------------------------------------- 1335 ! 1336 Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2) 1337 Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2) 1338 ! 1339 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1340 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1341 ! 1342 IF( nn_hls == 1 ) THEN !* halo size of 1 1343 ! 1344 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0 1345 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0 1346 ! 1347 ELSE !* larger halo size... 1348 ! 1349 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1 1350 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1 1351 ! 1352 ENDIF 1353 ! 1354 Ni_0 = Nie0 - Nis0 + 1 1355 Nj_0 = Nje0 - Njs0 + 1 1356 Ni_1 = Nie1 - Nis1 + 1 1357 Nj_1 = Nje1 - Njs1 + 1 1358 Ni_2 = Nie2 - Nis2 + 1 1359 Nj_2 = Nje2 - Njs2 + 1 1360 ! 1361 END SUBROUTINE init_doloop 1362 1280 1363 !!====================================================================== 1281 1364 END MODULE mppini
Note: See TracChangeset
for help on using the changeset viewer.
