Changeset 14338 for NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC
- Timestamp:
- 2021-01-25T08:50:49+01:00 (3 years ago)
- Location:
- NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC
- Files:
-
- 1 deleted
- 8 edited
- 3 moved
-
lbc_lnk_call_generic.h90 (moved) (moved from NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_multi_generic.h90) (4 diffs)
-
lbc_lnk_nc_generic.h90 (deleted)
-
lbc_lnk_neicoll_generic.h90 (moved) (moved from NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mpp_nc_generic.h90) (2 diffs)
-
lbc_lnk_pt2pt_generic.h90 (moved) (moved from NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mpp_lnk_generic.h90) (7 diffs)
-
lbc_nfd_ext_generic.h90 (modified) (11 diffs)
-
lbc_nfd_generic.h90 (modified) (21 diffs)
-
lbc_nfd_nogather_generic.h90 (modified) (27 diffs)
-
lbclnk.F90 (modified) (5 diffs)
-
lbcnfd.F90 (modified) (3 diffs)
-
lib_mpp.F90 (modified) (9 diffs)
-
mpp_nfd_generic.h90 (modified) (18 diffs)
-
mppini.F90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_call_generic.h90
r14337 r14338 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 1 #if defined DIM_2d 2 # define XD 2d 3 # define DIMS1 :,: 4 # define DIMS2 :,:,1,1 5 #endif 6 #if defined DIM_3d 7 # define XD 3d 8 # define DIMS1 :,:,: 9 # define DIMS2 :,:,:,1 10 #endif 11 #if defined DIM_4d 12 # define XD 4d 13 # define DIMS1 :,:,:,: 14 # define DIMS2 :,:,:,: 35 15 #endif 36 16 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, ncsten ) 17 SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION( & 18 & cdname & 19 & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & 20 & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & 21 & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & 22 & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & 23 & , kfillmode, pfillval, lsend, lrecv, ncsten ) 43 24 !!--------------------------------------------------------------------- 44 25 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 45 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1! arrays on which the lbc is applied46 ARRAY_TYPE(:,:,:,:) , OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9, &47 & pt10 , pt11 , pt12 , pt13 , pt14 , pt15, pt1626 REAL(PRECISION), DIMENSION(DIMS1) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 27 REAL(PRECISION), DIMENSION(DIMS1), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9, & 28 & pt10, pt11, pt12, pt13, pt14, pt15, pt16 48 29 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 49 30 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , cdna9, & … … 58 39 !! 59 40 INTEGER :: kfld ! number of elements that will be attributed 60 PTR_TYPE, DIMENSION(16) :: ptab_ptr ! pointer array41 TYPE(PTR_/**/XD/**/_/**/PRECISION), DIMENSION(16) :: ptab_ptr ! pointer array 61 42 CHARACTER(len=1) , DIMENSION(16) :: cdna_ptr ! nature of ptab_ptr grid-points 62 43 REAL(PRECISION) , DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary … … 66 47 ! 67 48 ! ! Load the first array 68 CALL ROUTINE_LOAD( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld )49 CALL load_ptr_/**/XD/**/_/**/PRECISION( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 69 50 ! 70 51 ! ! Look if more arrays are added 71 IF( PRESENT(psgn2 ) ) CALL ROUTINE_LOAD( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )72 IF( PRESENT(psgn3 ) ) CALL ROUTINE_LOAD( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )73 IF( PRESENT(psgn4 ) ) CALL ROUTINE_LOAD( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )74 IF( PRESENT(psgn5 ) ) CALL ROUTINE_LOAD( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )75 IF( PRESENT(psgn6 ) ) CALL ROUTINE_LOAD( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )76 IF( PRESENT(psgn7 ) ) CALL ROUTINE_LOAD( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )77 IF( PRESENT(psgn8 ) ) CALL ROUTINE_LOAD( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )78 IF( PRESENT(psgn9 ) ) CALL ROUTINE_LOAD( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )79 IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld )80 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld )81 IF( PRESENT(psgn12) ) CALL ROUTINE_LOAD( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld )82 IF( PRESENT(psgn13) ) CALL ROUTINE_LOAD( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld )83 IF( PRESENT(psgn14) ) CALL ROUTINE_LOAD( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld )84 IF( PRESENT(psgn15) ) CALL ROUTINE_LOAD( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld )85 IF( PRESENT(psgn16) ) CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld )52 IF( PRESENT(psgn2 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 53 IF( PRESENT(psgn3 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 54 IF( PRESENT(psgn4 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 55 IF( PRESENT(psgn5 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 56 IF( PRESENT(psgn6 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 57 IF( PRESENT(psgn7 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 58 IF( PRESENT(psgn8 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 59 IF( PRESENT(psgn9 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 60 IF( PRESENT(psgn10) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 61 IF( PRESENT(psgn11) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 62 IF( PRESENT(psgn12) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 63 IF( PRESENT(psgn13) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 64 IF( PRESENT(psgn14) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 65 IF( PRESENT(psgn15) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 66 IF( PRESENT(psgn16) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 86 67 ! 87 CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 68 IF( nn_comm == 1 ) THEN 69 CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 70 ELSE 71 CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 72 ENDIF 88 73 ! 89 END SUBROUTINE ROUTINE_MULTI74 END SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION 90 75 91 76 92 SUBROUTINE ROUTINE_LOAD( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld )77 SUBROUTINE load_ptr_/**/XD/**/_/**/PRECISION( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 93 78 !!--------------------------------------------------------------------- 94 ARRAY_TYPE(:,:,:,:), TARGET, INTENT(inout) :: ptab ! arrays on which the lbc is applied79 REAL(PRECISION), DIMENSION(DIMS1), TARGET, INTENT(inout) :: ptab ! arrays on which the lbc is applied 95 80 CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points 96 81 REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold boundary 97 PTR_TYPE, DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers82 TYPE(PTR_/**/XD/**/_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers 98 83 CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points 99 84 REAL(PRECISION) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary … … 102 87 ! 103 88 kfld = kfld + 1 104 ptab_ptr(kfld)% PTR_ptab=> ptab89 ptab_ptr(kfld)%pt/**/XD => ptab 105 90 cdna_ptr(kfld) = cdna 106 91 psgn_ptr(kfld) = psgn 107 92 ! 108 END SUBROUTINE ROUTINE_LOAD93 END SUBROUTINE load_ptr_/**/XD/**/_/**/PRECISION 109 94 110 #undef PRECISION 111 #undef ARRAY_TYPE 112 #undef PTR_TYPE 113 #undef PTR_ptab 95 #undef XD 96 #undef DIMS1 97 #undef DIMS2 -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_neicoll_generic.h90
r14337 r14338 1 # define NAT_IN(k) cd_nat(k) 2 # define SGN_IN(k) psgn(k) 3 # define F_SIZE(ptab) kfld 4 # define OPT_K(k) ,ipf 5 # if defined DIM_2d 6 # if defined SINGLE_PRECISION 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) 8 # else 9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) 10 # endif 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 12 # define K_SIZE(ptab) 1 13 # define L_SIZE(ptab) 1 14 # endif 15 # if defined DIM_3d 16 # if defined SINGLE_PRECISION 17 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) 18 # else 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) 20 # endif 21 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 22 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 23 # define L_SIZE(ptab) 1 24 # endif 25 # if defined DIM_4d 26 # if defined SINGLE_PRECISION 27 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) 28 # else 29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) 30 # endif 31 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 32 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 33 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 34 # endif 35 # if defined SINGLE_PRECISION 36 # define PRECISION sp 37 # define MPI_TYPE MPI_REAL 38 # else 39 # define PRECISION dp 40 # define MPI_TYPE MPI_DOUBLE_PRECISION 41 # endif 42 43 SUBROUTINE ROUTINE_NC( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 44 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 45 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 1 #if defined DIM_2d 2 # define XD 2d 3 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 4 # define K_SIZE(ptab) 1 5 # define L_SIZE(ptab) 1 6 #endif 7 #if defined DIM_3d 8 # define XD 3d 9 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 10 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 11 # define L_SIZE(ptab) 1 12 #endif 13 #if defined DIM_4d 14 # define XD 4d 15 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 16 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 17 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 18 #endif 19 #define F_SIZE(ptab) kfld 20 21 SUBROUTINE lbc_lnk_neicoll_/**/XD/**/_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 46 22 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 47 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 48 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 23 TYPE(PTR_/**/XD/**/_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 24 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 25 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary 26 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 49 27 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 50 28 REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) … … 261 239 ! 262 240 IF( ll_IdoNFold ) THEN 263 IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:)) ! self NFold264 ELSE ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill(jpno), zland OPT_K(:)) ! mpi NFold241 IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ipf ) ! self NFold 242 ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill(jpno), zland, ipf ) ! mpi NFold 265 243 ENDIF 266 244 ENDIF 267 268 END SUBROUTINE ROUTINE_NC 269 270 #undef PRECISION 271 #undef ARRAY_TYPE 272 #undef NAT_IN 273 #undef SGN_IN 245 ! 246 END SUBROUTINE lbc_lnk_neicoll_/**/XD/**/_/**/PRECISION 247 248 #undef XD 274 249 #undef ARRAY_IN 275 250 #undef K_SIZE 276 251 #undef L_SIZE 277 252 #undef F_SIZE 278 #undef OPT_K279 #undef MPI_TYPE -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90
r14337 r14338 1 #if defined MULTI 2 # define NAT_IN(k) cd_nat(k) 3 # define SGN_IN(k) psgn(k) 4 # define F_SIZE(ptab) kfld 5 # define OPT_K(k) ,ipf 6 # if defined DIM_2d 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 12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 13 # define K_SIZE(ptab) 1 14 # define L_SIZE(ptab) 1 15 # endif 16 # if defined DIM_3d 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 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 24 # define L_SIZE(ptab) 1 25 # endif 26 # if defined DIM_4d 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 32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 34 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 35 # endif 36 #else 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 42 # define NAT_IN(k) cd_nat 43 # define SGN_IN(k) psgn 44 # define F_SIZE(ptab) 1 45 # define OPT_K(k) 46 # if defined DIM_2d 47 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 48 # define K_SIZE(ptab) 1 49 # define L_SIZE(ptab) 1 50 # endif 51 # if defined DIM_3d 52 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) 53 # define K_SIZE(ptab) SIZE(ptab,3) 54 # define L_SIZE(ptab) 1 55 # endif 56 # if defined DIM_4d 57 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) 58 # define K_SIZE(ptab) SIZE(ptab,3) 59 # define L_SIZE(ptab) SIZE(ptab,4) 60 # endif 61 #endif 1 #if defined DIM_2d 2 # define XD 2d 3 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 4 # define K_SIZE(ptab) 1 5 # define L_SIZE(ptab) 1 6 #endif 7 #if defined DIM_3d 8 # define XD 3d 9 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 10 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 11 # define L_SIZE(ptab) 1 12 #endif 13 #if defined DIM_4d 14 # define XD 4d 15 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 16 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 17 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 18 #endif 19 #define F_SIZE(ptab) kfld 62 20 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 73 #if defined MULTI 74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 75 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 76 #else 77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv, ncsten ) 78 #endif 79 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 21 SUBROUTINE lbc_lnk_pt2pt_/**/XD/**/_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv ) 80 22 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 23 TYPE(PTR_/**/XD/**/_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 24 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 25 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary 26 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 83 27 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 84 28 REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 29 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 86 LOGICAL, OPTIONAL, INTENT(in ) :: ncsten ! 5-point or 9-point stencil87 30 ! 88 31 INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices … … 91 34 INTEGER :: ip0j, ip1j, im0j, im1j 92 35 INTEGER :: ishti, ishtj, ishti2, ishtj2 93 INTEGER :: i err36 INTEGER :: icomm, ierr 94 37 INTEGER :: idxs, idxr 95 38 INTEGER, DIMENSION(4) :: isizei, ishtsi, ishtri, ishtpi … … 110 53 #endif 111 54 ! 112 #if defined key_mpi3113 # if defined MULTI114 CALL lbc_lnk_nc ( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten )115 # else116 CALL lbc_lnk_nc_multi(cdname, ptab, cd_nat, psgn, kfillmode=kfillmode, pfillval=pfillval, lsend=lsend, lrecv=lrecv, ncsten=ncsten)117 # endif118 #else119 55 ! ----------------------------------------- ! 120 56 ! 1. local variables initialization ! … … 212 148 END DO 213 149 ! 150 #if ! defined key_mpi_off 214 151 IF( ln_timing ) CALL tic_tac(.TRUE.) 215 152 ! 153 icomm = mpi_comm_oce ! shorter name 216 154 ! non-blocking send of the western/eastern side using local temporary arrays 217 jn = jpwe ; IF( llsend(jn) ) CALL SENDROUTINE( 1, zsnd(ishts(jn)+1), iszall(jn), mpinei(jn), ireq(jn) ) 218 jn = jpea ; IF( llsend(jn) ) CALL SENDROUTINE( 2, zsnd(ishts(jn)+1), iszall(jn), mpinei(jn), ireq(jn) ) 155 jn = jpwe 156 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(ishts(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 1, icomm, ireq(jn), ierr ) 157 jn = jpea 158 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(ishts(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 2, icomm, ireq(jn), ierr ) 219 159 ! blocking receive of the western/eastern halo in local temporary arrays 220 jn = jpwe ; IF( llrecv(jn) ) CALL RECVROUTINE( 2, zrcv(ishtr(jn)+1), iszall(jn), mpinei(jn) ) 221 jn = jpea ; IF( llrecv(jn) ) CALL RECVROUTINE( 1, zrcv(ishtr(jn)+1), iszall(jn), mpinei(jn) ) 160 jn = jpwe 161 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(ishtr(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 2, icomm, MPI_STATUS_IGNORE, ierr ) 162 jn = jpea 163 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(ishtr(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 1, icomm, MPI_STATUS_IGNORE, ierr ) 222 164 ! 223 165 IF( ln_timing ) CALL tic_tac(.FALSE.) 166 #endif 224 167 ! 225 168 ! ----------------------------------- ! … … 264 207 ! 265 208 IF( ll_IdoNFold ) THEN 266 IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:)) ! self NFold267 ELSE ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill(jpno), zland OPT_K(:)) ! mpi NFold209 IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ipf ) ! self NFold 210 ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill(jpno), zland, ipf ) ! mpi NFold 268 211 ENDIF 269 212 ENDIF … … 284 227 END DO 285 228 ! 229 #if ! defined key_mpi_off 286 230 IF( ln_timing ) CALL tic_tac(.TRUE.) 287 231 ! 288 232 ! non-blocking send of the western/eastern side using local temporary arrays 289 jn = jpso ; IF( llsend(jn) ) CALL SENDROUTINE( 3, zsnd(ishts(jn)+1), iszall(jn), mpinei(jn), ireq(jn) ) 290 jn = jpno ; IF( llsend(jn) ) CALL SENDROUTINE( 4, zsnd(ishts(jn)+1), iszall(jn), mpinei(jn), ireq(jn) ) 233 jn = jpso 234 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(ishts(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 3, icomm, ireq(jn), ierr ) 235 jn = jpno 236 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(ishts(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 4, icomm, ireq(jn), ierr ) 291 237 ! blocking receive of the western/eastern halo in local temporary arrays 292 jn = jpso ; IF( llrecv(jn) ) CALL RECVROUTINE( 4, zrcv(ishtr(jn)+1), iszall(jn), mpinei(jn) ) 293 jn = jpno ; IF( llrecv(jn) ) CALL RECVROUTINE( 3, zrcv(ishtr(jn)+1), iszall(jn), mpinei(jn) ) 238 jn = jpso 239 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(ishtr(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 4, icomm, MPI_STATUS_IGNORE, ierr ) 240 jn = jpno 241 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(ishtr(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 3, icomm, MPI_STATUS_IGNORE, ierr ) 294 242 ! 295 243 IF( ln_timing ) CALL tic_tac(.FALSE.) 244 #endif 296 245 ! 297 246 ! ------------------------------------- ! … … 335 284 DEALLOCATE( zsnd, zrcv ) 336 285 ! 337 #endif 338 END SUBROUTINE ROUTINE_LNK 339 #undef PRECISION 340 #undef SENDROUTINE 341 #undef RECVROUTINE 342 #undef ARRAY_TYPE 343 #undef NAT_IN 344 #undef SGN_IN 286 END SUBROUTINE lbc_lnk_pt2pt_/**/XD/**/_/**/PRECISION 287 288 #undef XD 345 289 #undef ARRAY_IN 346 290 #undef K_SIZE 347 291 #undef L_SIZE 348 292 #undef F_SIZE 349 #undef OPT_K -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_nfd_ext_generic.h90
r14336 r14338 1 ! !== IN: ptab is an array ==!2 #define NAT_IN(k) cd_nat3 #define SGN_IN(k) psgn4 #define F_SIZE(ptab) 15 1 #if defined DIM_2d 2 # define XD 2d 6 3 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 7 4 # define K_SIZE(ptab) 1 8 5 # define L_SIZE(ptab) 1 6 #else 7 === NOT CODED === 9 8 #endif 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 9 #define F_SIZE(ptab) 1 17 10 18 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj )11 SUBROUTINE lbc_nfd_ext_/**/XD/**/_/**/PRECISION( ptab, cd_nat, psgn, kextj ) 19 12 !!---------------------------------------------------------------------- 20 INTEGER , INTENT(in ) :: kextj ! extra halo width at north fold, declared before its use in ARRAY_TYPE 21 ARRAY_TYPE(:,1-kextj:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 22 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 23 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 13 REAL(PRECISION), DIMENSION(:,1-kextj:),INTENT(inout) :: ptab 14 CHARACTER(len=1), INTENT(in ) :: cd_nat ! nature of array grid-points 15 REAL(PRECISION), INTENT(in ) :: psgn ! sign used across the north fold boundary 16 INTEGER, INTENT(in ) :: kextj ! extra halo width at north fold 17 !! INTEGER , INTENT(in ) :: kextj ! extra halo width at north fold, declared before its use in ptab 24 18 ! 25 19 INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices … … 31 25 ipl = L_SIZE(ptab) ! 4th - 32 26 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 33 !34 27 ! 35 28 SELECT CASE ( jpni ) … … 45 38 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 46 39 ! 47 SELECT CASE ( NAT_IN(jf))40 SELECT CASE ( cd_nat ) 48 41 CASE ( 'T' , 'W' ) ! T-, W-point 49 42 DO jh = 0, kextj 50 43 DO ji = 2, jpiglo 51 44 ijt = jpiglo-ji+2 52 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(ijt,ipj-2-jh,:,:,jf)45 ARRAY_IN(ji,ipj+jh,:,:,jf) = psgn * ARRAY_IN(ijt,ipj-2-jh,:,:,jf) 53 46 END DO 54 ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(3,ipj-2-jh,:,:,jf)47 ARRAY_IN(1,ipj+jh,:,:,jf) = psgn * ARRAY_IN(3,ipj-2-jh,:,:,jf) 55 48 END DO 56 49 DO ji = jpiglo/2+1, jpiglo 57 50 ijt = jpiglo-ji+2 58 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)* ARRAY_IN(ijt,ipjm1,:,:,jf)51 ARRAY_IN(ji,ipjm1,:,:,jf) = psgn * ARRAY_IN(ijt,ipjm1,:,:,jf) 59 52 END DO 60 53 CASE ( 'U' ) ! U-point … … 62 55 DO ji = 2, jpiglo-1 63 56 iju = jpiglo-ji+1 64 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(iju,ipj-2-jh,:,:,jf)57 ARRAY_IN(ji,ipj+jh,:,:,jf) = psgn * ARRAY_IN(iju,ipj-2-jh,:,:,jf) 65 58 END DO 66 ARRAY_IN( 1 ,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN( 2 ,ipj-2-jh,:,:,jf)67 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(jpiglo-1,ipj-2-jh,:,:,jf)59 ARRAY_IN( 1 ,ipj+jh,:,:,jf) = psgn * ARRAY_IN( 2 ,ipj-2-jh,:,:,jf) 60 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = psgn * ARRAY_IN(jpiglo-1,ipj-2-jh,:,:,jf) 68 61 END DO 69 62 DO ji = jpiglo/2, jpiglo-1 70 63 iju = jpiglo-ji+1 71 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)* ARRAY_IN(iju,ipjm1,:,:,jf)64 ARRAY_IN(ji,ipjm1,:,:,jf) = psgn * ARRAY_IN(iju,ipjm1,:,:,jf) 72 65 END DO 73 66 CASE ( 'V' ) ! V-point … … 75 68 DO ji = 2, jpiglo 76 69 ijt = jpiglo-ji+2 77 ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(ijt,ipj-2-jh,:,:,jf)78 ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf)* ARRAY_IN(ijt,ipj-3-jh,:,:,jf)70 ARRAY_IN(ji,ipj-1+jh,:,:,jf) = psgn * ARRAY_IN(ijt,ipj-2-jh,:,:,jf) 71 ARRAY_IN(ji,ipj+jh ,:,:,jf) = psgn * ARRAY_IN(ijt,ipj-3-jh,:,:,jf) 79 72 END DO 80 ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(3,ipj-3-jh,:,:,jf)73 ARRAY_IN(1,ipj+jh,:,:,jf) = psgn * ARRAY_IN(3,ipj-3-jh,:,:,jf) 81 74 END DO 82 75 CASE ( 'F' ) ! F-point … … 84 77 DO ji = 1, jpiglo-1 85 78 iju = jpiglo-ji+1 86 ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(iju,ipj-2-jh,:,:,jf)87 ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf)* ARRAY_IN(iju,ipj-3-jh,:,:,jf)79 ARRAY_IN(ji,ipj-1+jh,:,:,jf) = psgn * ARRAY_IN(iju,ipj-2-jh,:,:,jf) 80 ARRAY_IN(ji,ipj+jh ,:,:,jf) = psgn * ARRAY_IN(iju,ipj-3-jh,:,:,jf) 88 81 END DO 89 82 END DO 90 83 DO jh = 0, kextj 91 ARRAY_IN( 1 ,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN( 2 ,ipj-3-jh,:,:,jf)92 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(jpiglo-1,ipj-3-jh,:,:,jf)84 ARRAY_IN( 1 ,ipj+jh,:,:,jf) = psgn * ARRAY_IN( 2 ,ipj-3-jh,:,:,jf) 85 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = psgn * ARRAY_IN(jpiglo-1,ipj-3-jh,:,:,jf) 93 86 END DO 94 87 END SELECT … … 98 91 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 99 92 ! 100 SELECT CASE ( NAT_IN(jf))93 SELECT CASE ( cd_nat ) 101 94 CASE ( 'T' , 'W' ) ! T-, W-point 102 95 DO jh = 0, kextj 103 96 DO ji = 1, jpiglo 104 97 ijt = jpiglo-ji+1 105 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(ijt,ipj-1-jh,:,:,jf)98 ARRAY_IN(ji,ipj+jh,:,:,jf) = psgn * ARRAY_IN(ijt,ipj-1-jh,:,:,jf) 106 99 END DO 107 100 END DO … … 110 103 DO ji = 1, jpiglo-1 111 104 iju = jpiglo-ji 112 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(iju,ipj-1-jh,:,:,jf)105 ARRAY_IN(ji,ipj+jh,:,:,jf) = psgn * ARRAY_IN(iju,ipj-1-jh,:,:,jf) 113 106 END DO 114 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(jpiglo-2,ipj-1-jh,:,:,jf)107 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = psgn * ARRAY_IN(jpiglo-2,ipj-1-jh,:,:,jf) 115 108 END DO 116 109 CASE ( 'V' ) ! V-point … … 118 111 DO ji = 1, jpiglo 119 112 ijt = jpiglo-ji+1 120 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(ijt,ipj-2-jh,:,:,jf)113 ARRAY_IN(ji,ipj+jh,:,:,jf) = psgn * ARRAY_IN(ijt,ipj-2-jh,:,:,jf) 121 114 END DO 122 115 END DO 123 116 DO ji = jpiglo/2+1, jpiglo 124 117 ijt = jpiglo-ji+1 125 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)* ARRAY_IN(ijt,ipjm1,:,:,jf)118 ARRAY_IN(ji,ipjm1,:,:,jf) = psgn * ARRAY_IN(ijt,ipjm1,:,:,jf) 126 119 END DO 127 120 CASE ( 'F' ) ! F-point … … 129 122 DO ji = 1, jpiglo-1 130 123 iju = jpiglo-ji 131 ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf)* ARRAY_IN(iju,ipj-2-jh,:,:,jf)124 ARRAY_IN(ji,ipj+jh ,:,:,jf) = psgn * ARRAY_IN(iju,ipj-2-jh,:,:,jf) 132 125 END DO 133 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)* ARRAY_IN(jpiglo-2,ipj-2-jh,:,:,jf)126 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = psgn * ARRAY_IN(jpiglo-2,ipj-2-jh,:,:,jf) 134 127 END DO 135 128 DO ji = jpiglo/2+1, jpiglo-1 136 129 iju = jpiglo-ji 137 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)* ARRAY_IN(iju,ipjm1,:,:,jf)130 ARRAY_IN(ji,ipjm1,:,:,jf) = psgn * ARRAY_IN(iju,ipjm1,:,:,jf) 138 131 END DO 139 132 END SELECT … … 143 136 END DO 144 137 ! 145 END SUBROUTINE ROUTINE_NFD138 END SUBROUTINE lbc_nfd_ext_/**/XD/**/_/**/PRECISION 146 139 147 #undef PRECISION 148 #undef ARRAY_TYPE 140 #undef XD 149 141 #undef ARRAY_IN 150 #undef NAT_IN151 #undef SGN_IN152 142 #undef K_SIZE 153 143 #undef L_SIZE -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_nfd_generic.h90
r14336 r14338 1 #if defined MULTI 2 # define NAT_IN(k) cd_nat(k) 3 # define SGN_IN(k) psgn(k) 4 # define F_SIZE(ptab) kfld 5 # if defined DIM_2d 6 # if defined SINGLE_PRECISION 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 8 # else 9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 10 # endif 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 12 # define J_SIZE(ptab) SIZE(ptab(1)%pt2d,2) 13 # define K_SIZE(ptab) 1 14 # define L_SIZE(ptab) 1 15 # endif 16 # if defined DIM_3d 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 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) 24 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 25 # define L_SIZE(ptab) 1 26 # endif 27 # if defined DIM_4d 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 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) 35 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 36 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 37 # endif 38 #else 39 ! !== IN: ptab is an array ==! 40 # define NAT_IN(k) cd_nat 41 # define SGN_IN(k) psgn 42 # define F_SIZE(ptab) 1 43 # if defined DIM_2d 44 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 45 # define J_SIZE(ptab) SIZE(ptab,2) 46 # define K_SIZE(ptab) 1 47 # define L_SIZE(ptab) 1 48 # endif 49 # if defined DIM_3d 50 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) 51 # define J_SIZE(ptab) SIZE(ptab,2) 52 # define K_SIZE(ptab) SIZE(ptab,3) 53 # define L_SIZE(ptab) 1 54 # endif 55 # if defined DIM_4d 56 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) 57 # define J_SIZE(ptab) SIZE(ptab,2) 58 # define K_SIZE(ptab) SIZE(ptab,3) 59 # define L_SIZE(ptab) SIZE(ptab,4) 60 # endif 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 1 #if defined DIM_2d 2 # define XD 2d 3 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 4 # define J_SIZE(ptab) SIZE(ptab(1)%pt2d,2) 5 # define K_SIZE(ptab) 1 6 # define L_SIZE(ptab) 1 66 7 #endif 8 #if defined DIM_3d 9 # define XD 3d 10 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 11 # define J_SIZE(ptab) SIZE(ptab(1)%pt3d,2) 12 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 13 # define L_SIZE(ptab) 1 14 #endif 15 #if defined DIM_4d 16 # define XD 4d 17 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 18 # define J_SIZE(ptab) SIZE(ptab(1)%pt4d,2) 19 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 20 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 21 #endif 22 #define F_SIZE(ptab) kfld 67 23 68 # if defined SINGLE_PRECISION 69 # define PRECISION sp 70 # else 71 # define PRECISION dp 72 # endif 73 74 #if defined MULTI 75 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 76 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 77 #else 78 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn ) 79 #endif 80 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 24 SUBROUTINE lbc_nfd_/**/XD/**/_/**/PRECISION( ptab, cd_nat, psgn, kfld ) 25 TYPE(PTR_/**/XD/**/_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 26 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 27 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary 28 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 83 29 ! 84 30 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices … … 96 42 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 97 43 ! 98 SELECT CASE ( NAT_IN(jf))44 SELECT CASE ( cd_nat(jf) ) 99 45 CASE ( 'T' , 'W' ) ! T-, W-point 100 46 DO jl = 1, ipl; DO jk = 1, ipk … … 108 54 ii1 = ji ! ends at: nn_hls 109 55 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 110 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)56 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 111 57 END DO 112 58 DO ji = 1, 1 ! point nn_hls+1 113 59 ii1 = nn_hls + ji 114 60 ii2 = ii1 115 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)61 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 116 62 END DO 117 63 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 118 64 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 119 65 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 120 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)66 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 121 67 END DO 122 68 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 123 69 ii1 = jpiglo - nn_hls + ji 124 70 ii2 = nn_hls + ji 125 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)71 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 126 72 END DO 127 73 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 128 74 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 129 75 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 130 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)76 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 131 77 END DO 132 78 END DO … … 140 86 ii1 = jpiglo/2 + ji + 1 ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls - 1) + 1 = jpiglo - nn_hls 141 87 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1) + 1 = nn_hls + 2 142 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)88 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 143 89 END DO 144 90 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) … … 146 92 ii1 = ji ! ends at: nn_hls 147 93 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 148 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)94 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 149 95 END DO 150 96 ! ! last nn_hls-1 points: have been / will done by e-w periodicity … … 163 109 ii1 = ji ! ends at: nn_hls 164 110 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 165 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)111 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 166 112 END DO 167 113 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 168 114 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 169 115 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 170 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)116 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 171 117 END DO 172 118 DO ji = 1, nn_hls ! last nn_hls points 173 119 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 174 120 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 175 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)121 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 176 122 END DO 177 123 END DO … … 185 131 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 186 132 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 187 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)133 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 188 134 END DO 189 135 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) … … 191 137 ii1 = ji ! ends at: nn_hls 192 138 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 193 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)139 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 194 140 END DO 195 141 ! ! last nn_hls-1 points: have been / will done by e-w periodicity … … 208 154 ii1 = ji ! ends at: nn_hls 209 155 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 210 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)156 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 211 157 END DO 212 158 DO ji = 1, 1 ! point nn_hls+1 213 159 ii1 = nn_hls + ji 214 160 ii2 = ii1 215 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)161 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 216 162 END DO 217 163 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 218 164 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 219 165 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 220 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)166 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 221 167 END DO 222 168 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 223 169 ii1 = jpiglo - nn_hls + ji 224 170 ii2 = nn_hls + ji 225 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)171 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 226 172 END DO 227 173 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 228 174 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 229 175 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 230 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)176 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 231 177 END DO 232 178 END DO … … 244 190 ii1 = ji ! ends at: nn_hls 245 191 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 246 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)192 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 247 193 END DO 248 194 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 249 195 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 250 196 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 251 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)197 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 252 198 END DO 253 199 DO ji = 1, nn_hls ! last nn_hls points 254 200 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 255 201 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 256 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)257 END DO 258 END DO 259 ! 260 END DO; END DO 261 END SELECT ! NAT_IN(jf)202 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 203 END DO 204 END DO 205 ! 206 END DO; END DO 207 END SELECT ! cd_nat(jf) 262 208 ! 263 209 ENDIF ! c_NFtype == 'T' … … 265 211 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 266 212 ! 267 SELECT CASE ( NAT_IN(jf))213 SELECT CASE ( cd_nat(jf) ) 268 214 CASE ( 'T' , 'W' ) ! T-, W-point 269 215 DO jl = 1, ipl; DO jk = 1, ipk … … 300 246 ii1 = ji ! ends at: nn_hls 301 247 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)248 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 303 249 END DO 304 250 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 305 251 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 306 252 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)253 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 308 254 END DO 309 255 DO ji = 1, nn_hls ! last nn_hls points 310 256 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 311 257 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)258 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 313 259 END DO 314 260 END DO … … 326 272 ii1 = ji ! ends at: nn_hls-1 327 273 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)274 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 329 275 END DO 330 276 DO ji = 1, 1 ! point nn_hls 331 277 ii1 = nn_hls + ji - 1 332 278 ii2 = jpiglo - ii1 333 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)279 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 334 280 END DO 335 281 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 336 282 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 337 283 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)284 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 339 285 END DO 340 286 DO ji = 1, 1 ! point jpiglo - nn_hls 341 287 ii1 = jpiglo - nn_hls + ji - 1 342 288 ii2 = ii1 343 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)289 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 344 290 END DO 345 291 DO ji = 1, nn_hls ! last nn_hls points 346 292 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 347 293 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)294 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 349 295 END DO 350 296 END DO … … 362 308 ii1 = ji ! ends at: nn_hls 363 309 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)310 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 365 311 END DO 366 312 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 367 313 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 368 314 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)315 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 370 316 END DO 371 317 DO ji = 1, nn_hls ! last nn_hls points 372 318 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 373 319 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)320 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 375 321 END DO 376 322 END DO … … 384 330 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 385 331 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)332 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 387 333 END DO 388 334 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) … … 390 336 ii1 = ji ! ends at: nn_hls 391 337 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)338 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 393 339 END DO 394 340 ! ! last nn_hls points: have been / will done by e-w periodicity … … 407 353 ii1 = ji ! ends at: nn_hls-1 408 354 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)355 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 410 356 END DO 411 357 DO ji = 1, 1 ! point nn_hls 412 358 ii1 = nn_hls + ji - 1 413 359 ii2 = jpiglo - ii1 414 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)360 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 415 361 END DO 416 362 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 417 363 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 418 364 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)365 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 420 366 END DO 421 367 DO ji = 1, 1 ! point jpiglo - nn_hls 422 368 ii1 = jpiglo - nn_hls + ji - 1 423 369 ii2 = ii1 424 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)370 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 425 371 END DO 426 372 DO ji = 1, nn_hls ! last nn_hls points 427 373 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 428 374 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)375 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 430 376 END DO 431 377 END DO … … 439 385 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 440 386 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)387 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 442 388 END DO 443 389 DO ji = 1, nn_hls-1 ! first nn_hls-1 points: redo them just in case (if e-w periodocity already done) … … 445 391 ii1 = ji ! ends at: nn_hls 446 392 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)393 ARRAY_IN(ii1,ij1,jk,jl,jf) = psgn(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 448 394 END DO 449 395 ! ! last nn_hls points: have been / will done by e-w periodicity … … 451 397 ! 452 398 END DO; END DO 453 END SELECT ! NAT_IN(jf)399 END SELECT ! cd_nat(jf) 454 400 ! 455 401 ENDIF ! c_NFtype == 'F' … … 457 403 END DO ! ipf 458 404 ! 459 END SUBROUTINE ROUTINE_NFD405 END SUBROUTINE lbc_nfd_/**/XD/**/_/**/PRECISION 460 406 461 #undef PRECISION 462 #undef ARRAY_TYPE 407 #undef XD 463 408 #undef ARRAY_IN 464 #undef NAT_IN465 #undef SGN_IN466 409 #undef J_SIZE 467 410 #undef K_SIZE -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r14336 r14338 1 #if defined MULTI 2 # define NAT_IN(k) cd_nat(k) 3 # define SGN_IN(k) psgn(k) 4 # define F_SIZE(ptab) kfld 5 # if defined DIM_2d 6 # if defined SINGLE_PRECISION 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 8 # else 9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 10 # endif 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 12 # define K_SIZE(ptab) 1 13 # define L_SIZE(ptab) 1 14 # endif 15 # if defined DIM_3d 16 # if defined SINGLE_PRECISION 17 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 18 # else 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 20 # endif 21 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 22 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 23 # define L_SIZE(ptab) 1 24 # endif 25 # if defined DIM_4d 26 # if defined SINGLE_PRECISION 27 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 28 # else 29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 30 # endif 31 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 32 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 33 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 34 # endif 35 # if defined SINGLE_PRECISION 36 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f) 37 # else 38 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f) 39 # endif 40 # define J_SIZE(ptab2) SIZE(ptab2(1)%pt4d,2) 41 # define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l) 42 #else 43 ! !== IN: ptab is an array ==! 44 # define NAT_IN(k) cd_nat 45 # define SGN_IN(k) psgn 46 # define F_SIZE(ptab) 1 47 # if defined DIM_2d 48 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 49 # define K_SIZE(ptab) 1 50 # define L_SIZE(ptab) 1 51 # endif 52 # if defined DIM_3d 53 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) 54 # define K_SIZE(ptab) SIZE(ptab,3) 55 # define L_SIZE(ptab) 1 56 # endif 57 # if defined DIM_4d 58 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) 59 # define K_SIZE(ptab) SIZE(ptab,3) 60 # define L_SIZE(ptab) SIZE(ptab,4) 61 # endif 62 # define J_SIZE(ptab2) SIZE(ptab2,2) 63 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 64 # if defined SINGLE_PRECISION 65 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 66 # define ARRAY2_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 67 # else 68 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 69 # define ARRAY2_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 70 # endif 71 # endif 72 # ifdef SINGLE_PRECISION 73 # define PRECISION sp 74 # else 75 # define PRECISION dp 76 # endif 77 SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld ) 1 #if defined DIM_2d 2 # define XD 2d 3 # define DIMS_IN :,: 4 # define ARRAY_IN(i,j,k,l) ptab(i,j) 5 # define K_SIZE(ptab) 1 6 # define L_SIZE(ptab) 1 7 #endif 8 #if defined DIM_3d 9 # define XD 3d 10 # define DIMS_IN :,:,: 11 # define ARRAY_IN(i,j,k,l) ptab(i,j,k) 12 # define K_SIZE(ptab) SIZE(ptab,3) 13 # define L_SIZE(ptab) 1 14 #endif 15 #if defined DIM_4d 16 # define XD 4d 17 # define DIMS_IN :,:,:,: 18 # define ARRAY_IN(i,j,k,l) ptab(i,j,k,l) 19 # define K_SIZE(ptab) SIZE(ptab,3) 20 # define L_SIZE(ptab) SIZE(ptab,4) 21 #endif 22 23 SUBROUTINE lbc_nfd_nogather_/**/XD/**/_/**/PRECISION( ptab, ptab2, cd_nat, psgn ) 78 24 !!---------------------------------------------------------------------- 79 25 !! … … 82 28 !! 83 29 !!---------------------------------------------------------------------- 84 ARRAY_TYPE(:,:,:,:,:) 85 ARRAY2_TYPE(:,:,:,:,:) 86 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 87 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 88 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 30 REAL(PRECISION), DIMENSION(DIMS_IN), INTENT(inout) :: ptab ! 31 REAL(PRECISION), DIMENSION(:,:,:,:), INTENT(inout) :: ptab2 ! 32 CHARACTER(len=1), INTENT(in ) :: cd_nat ! nature of array grid-points 33 REAL(PRECISION), INTENT(in ) :: psgn ! sign used across the north fold boundary 89 34 ! 90 INTEGER :: ji, jj, jk, jn, ii, jl, jh, jf! dummy loop indices91 INTEGER :: ip i, ipj, ipk, ipl, ipf, iij, ijj! dimension of the input array35 INTEGER :: ji, jj, jk, jn, jl, jh ! dummy loop indices 36 INTEGER :: ipk, ipl, ii, iij, ijj ! dimension of the input array 92 37 INTEGER :: ijt, iju, ijta, ijua, jia, startloop, endloop 93 38 LOGICAL :: l_fast_exchanges 94 39 !!---------------------------------------------------------------------- 95 ipj = J_SIZE(ptab2) ! 2nd dimension of input array96 40 ipk = K_SIZE(ptab) ! 3rd dimension of output array 97 41 ipl = L_SIZE(ptab) ! 4th - 98 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)99 42 ! 100 ! Security check for further developments101 IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' )102 43 ! 2nd dimension determines exchange speed 103 IF ( ipj== 1 ) THEN44 IF ( SIZE(ptab2,2) == 1 ) THEN 104 45 l_fast_exchanges = .TRUE. 105 46 ELSE 106 47 l_fast_exchanges = .FALSE. 107 48 ENDIF 108 !109 DO jf = 1, ipf ! Loop over the number of arrays to be processed110 49 ! 111 50 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 112 51 ! 113 SELECT CASE ( NAT_IN(jf))52 SELECT CASE ( cd_nat ) 114 53 ! 115 54 CASE ( 'T' , 'W' ) ! T-, W-point … … 123 62 DO ji = startloop, jpi 124 63 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 125 ARRAY_IN(ji,ijj,jk,jl ,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)64 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 126 65 END DO 127 66 END DO … … 132 71 ijj = jpj -jj +1 133 72 DO ii = 0, nn_hls-1 134 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)73 ARRAY_IN(ii+1,ijj,jk,jl) = psgn * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,jk,jl) 135 74 END DO 136 75 END DO … … 153 92 ijta = jpiglo - jia + 2 154 93 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 155 ARRAY_IN(ji,jpj-nn_hls,jk,jl ,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl,jf)94 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ARRAY_IN(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl) 156 95 ELSE 157 ARRAY_IN(ji,jpj-nn_hls,jk,jl ,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf)96 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(ijt,nn_hls+1,jk,jl) 158 97 ENDIF 159 98 END DO … … 172 111 DO ji = 1, endloop 173 112 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 174 ARRAY_IN(ji,ijj,jk,jl ,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)113 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 175 114 END DO 176 115 END DO … … 180 119 ijj = jpj -jj +1 181 120 DO ii = 0, nn_hls-1 182 ARRAY_IN(ii+1,ijj,:,: ,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf)121 ARRAY_IN(ii+1,ijj,:,:) = psgn * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:) 183 122 END DO 184 123 END DO … … 188 127 ijj = jpj -jj +1 189 128 DO ii = 1, nn_hls 190 ARRAY_IN(jpi-ii+1,ijj,:,: ,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf)129 ARRAY_IN(jpi-ii+1,ijj,:,:) = psgn * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:) 191 130 END DO 192 131 END DO … … 213 152 ijua = jpiglo - jia + 1 214 153 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 215 ARRAY_IN(ji,jpj-nn_hls,jk,jl ,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl,jf)154 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl) 216 155 ELSE 217 ARRAY_IN(ji,jpj-nn_hls,jk,jl ,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf)156 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(iju,nn_hls+1,jk,jl) 218 157 ENDIF 219 158 END DO … … 234 173 DO ji = startloop, jpi 235 174 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 236 ARRAY_IN(ji,ijj,jk,jl ,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)175 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 237 176 END DO 238 177 END DO … … 242 181 DO ji = startloop, jpi 243 182 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 244 ARRAY_IN(ji,jpj,jk,jl ,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf)183 ARRAY_IN(ji,jpj,jk,jl) = psgn * ptab2(ijt,1,jk,jl) 245 184 END DO 246 185 END DO; END DO … … 249 188 ijj = jpj-jj+1 250 189 DO ii = 0, nn_hls-1 251 ARRAY_IN(ii+1,ijj,:,: ,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:,jf)190 ARRAY_IN(ii+1,ijj,:,:) = psgn * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:) 252 191 END DO 253 192 END DO … … 265 204 DO ji = 1, endloop 266 205 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 267 ARRAY_IN(ji,ijj,jk,jl ,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)206 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 268 207 END DO 269 208 END DO … … 273 212 DO ji = 1, endloop 274 213 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 275 ARRAY_IN(ji,jpj,jk,jl ,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf)214 ARRAY_IN(ji,jpj,jk,jl) = psgn * ptab2(iju,1,jk,jl) 276 215 END DO 277 216 END DO; END DO 278 217 IF (nimpp .eq. 1) THEN 279 218 DO ii = 1, nn_hls 280 ARRAY_IN(ii,jpj,:,: ,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:,jf)219 ARRAY_IN(ii,jpj,:,:) = psgn * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:) 281 220 END DO 282 221 IF ( .NOT. l_fast_exchanges ) THEN … … 284 223 ijj = jpj -jj 285 224 DO ii = 0, nn_hls-1 286 ARRAY_IN(ii+1,ijj,:,: ,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf)225 ARRAY_IN(ii+1,ijj,:,:) = psgn * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:) 287 226 END DO 288 227 END DO … … 291 230 IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 292 231 DO ii = 1, nn_hls 293 ARRAY_IN(jpi-ii+1,jpj,:,: ,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:,jf)232 ARRAY_IN(jpi-ii+1,jpj,:,:) = psgn * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:) 294 233 END DO 295 234 IF ( .NOT. l_fast_exchanges ) THEN … … 297 236 ijj = jpj -jj 298 237 DO ii = 1, nn_hls 299 ARRAY_IN(jpi-ii+1,ijj,:,: ,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf)238 ARRAY_IN(jpi-ii+1,ijj,:,:) = psgn * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:) 300 239 END DO 301 240 END DO … … 309 248 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 310 249 ! 311 SELECT CASE ( NAT_IN(jf))250 SELECT CASE ( cd_nat ) 312 251 CASE ( 'T' , 'W' ) ! T-, W-point 313 252 DO jl = 1, ipl; DO jk = 1, ipk … … 316 255 DO ji = 1, jpi 317 256 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)257 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 319 258 END DO 320 259 END DO … … 332 271 DO ji = 1, endloop 333 272 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)273 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 335 274 END DO 336 275 END DO … … 342 281 DO ii = 1, nn_hls 343 282 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)283 ARRAY_IN(iij,ijj,jk,jl) = psgn * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl) 345 284 END DO 346 285 END DO … … 354 293 DO ji = 1, jpi 355 294 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)295 ARRAY_IN(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 357 296 END DO 358 297 END DO … … 371 310 DO ji = startloop, jpi 372 311 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)312 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(ijt,nn_hls+1,jk,jl) 374 313 END DO 375 314 END DO; END DO … … 388 327 DO ji = 1, endloop 389 328 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)329 ARRAY_IN(ji,ijj ,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 391 330 END DO 392 331 END DO … … 398 337 DO ii = 1, nn_hls 399 338 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)339 ARRAY_IN(iij,ijj,jk,jl) = psgn * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl) 401 340 END DO 402 341 END DO … … 421 360 DO ji = startloop, endloop 422 361 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)362 ARRAY_IN(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(iju,nn_hls+1,jk,jl) 424 363 END DO 425 364 END DO; END DO … … 431 370 ENDIF ! c_NFtype == 'F' 432 371 ! 433 END DO ! End jf loop434 END SUBROUTINE ROUTINE_NFD 435 #undef PRECISION436 #undef ARRAY_TYPE372 END SUBROUTINE lbc_nfd_nogather_/**/XD/**/_/**/PRECISION 373 374 #undef XD 375 #undef DIMS_IN 437 376 #undef ARRAY_IN 438 #undef NAT_IN439 #undef SGN_IN440 #undef J_SIZE441 377 #undef K_SIZE 442 378 #undef L_SIZE 443 #undef F_SIZE444 #undef ARRAY2_TYPE445 #undef ARRAY2_IN -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbclnk.F90
r14314 r14338 23 23 USE lbcnfd ! north fold 24 24 USE in_out_manager ! I/O manager 25 #if ! defined key_mpi_off 26 USE MPI 27 #endif 25 28 26 29 IMPLICIT NONE … … 28 31 29 32 INTERFACE lbc_lnk 30 MODULE PROCEDURE mpp_lnk_2d_sp , mpp_lnk_3d_sp , mpp_lnk_4d_sp 31 MODULE PROCEDURE mpp_lnk_2d_dp , mpp_lnk_3d_dp , mpp_lnk_4d_dp 32 END INTERFACE 33 INTERFACE lbc_lnk_ptr 34 MODULE PROCEDURE mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp 35 MODULE PROCEDURE mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp 36 END INTERFACE 37 INTERFACE lbc_lnk_multi 38 MODULE PROCEDURE lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp 39 MODULE PROCEDURE lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 40 END INTERFACE 41 INTERFACE lbc_lnk_nc_multi 42 MODULE PROCEDURE lbc_lnk_nc_2d_sp, lbc_lnk_nc_3d_sp, lbc_lnk_nc_4d_sp 43 MODULE PROCEDURE lbc_lnk_nc_2d_dp, lbc_lnk_nc_3d_dp, lbc_lnk_nc_4d_dp 44 END INTERFACE 45 INTERFACE lbc_lnk_nc 46 MODULE PROCEDURE mpp_lnk_nc_2d_sp, mpp_lnk_nc_3d_sp, mpp_lnk_nc_4d_sp 47 MODULE PROCEDURE mpp_lnk_nc_2d_dp, mpp_lnk_nc_3d_dp, mpp_lnk_nc_4d_dp 33 MODULE PROCEDURE lbc_lnk_call_2d_sp, lbc_lnk_call_3d_sp, lbc_lnk_call_4d_sp 34 MODULE PROCEDURE lbc_lnk_call_2d_dp, lbc_lnk_call_3d_dp, lbc_lnk_call_4d_dp 35 END INTERFACE 36 37 INTERFACE lbc_lnk_pt2pt 38 MODULE PROCEDURE lbc_lnk_pt2pt_2d_sp , lbc_lnk_pt2pt_3d_sp , lbc_lnk_pt2pt_4d_sp 39 MODULE PROCEDURE lbc_lnk_pt2pt_2d_dp , lbc_lnk_pt2pt_3d_dp , lbc_lnk_pt2pt_4d_dp 40 END INTERFACE 41 42 INTERFACE lbc_lnk_neicoll 43 MODULE PROCEDURE lbc_lnk_neicoll_2d_sp , lbc_lnk_neicoll_3d_sp , lbc_lnk_neicoll_4d_sp 44 MODULE PROCEDURE lbc_lnk_neicoll_2d_dp , lbc_lnk_neicoll_3d_dp , lbc_lnk_neicoll_4d_dp 48 45 END INTERFACE 49 46 ! … … 52 49 END INTERFACE 53 50 54 INTERFACE mpp_nfd55 MODULE PROCEDURE mpp_nfd_2d_sp , mpp_nfd_3d_sp , mpp_nfd_4d_sp56 MODULE PROCEDURE mpp_nfd_2d_dp , mpp_nfd_3d_dp , mpp_nfd_4d_dp57 MODULE PROCEDURE mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp58 MODULE PROCEDURE mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp59 60 END INTERFACE61 62 51 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 63 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions64 52 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 65 PUBLIC lbc_lnk_nc ! ocean/ice lateral boundary conditions (MPI3 version)66 PUBLIC lbc_lnk_nc_multi ! modified ocean/ice lateral boundary conditions (MPI3 version)67 68 #if ! defined key_mpi_off69 !$AGRIF_DO_NOT_TREAT70 INCLUDE 'mpif.h'71 !$AGRIF_END_DO_NOT_TREAT72 #endif73 74 INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 175 INTEGER, PUBLIC, PARAMETER :: jpfillcst = 276 INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 377 INTEGER, PUBLIC, PARAMETER :: jpfillperio = 478 INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 579 53 80 54 !! * Substitutions … … 88 62 89 63 !!---------------------------------------------------------------------- 90 !! *** l oad_ptr_(2,3,4)d***64 !! *** lbc_lnk_call_[234]d_[sd]p *** 91 65 !! 92 66 !! * Dummy Argument : 93 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 67 !! in ==> cdname ! name of the calling subroutine (for monitoring) 68 !! ptab ! array to be loaded (2D, 3D or 4D) 94 69 !! cd_nat ! nature of pt2d array grid-points 95 70 !! psgn ! sign used across the north fold boundary … … 99 74 !! kfld ! number of elements that has been attributed 100 75 !!---------------------------------------------------------------------- 101 102 !!---------------------------------------------------------------------- 103 !! *** lbc_lnk_(2,3,4)d_multi *** 104 !! *** load_ptr_(2,3,4)d *** 105 !! 106 !! * Argument : dummy argument use in lbc_lnk_multi_... routines 107 !! 108 !!---------------------------------------------------------------------- 109 76 ! 77 !!---------------------------------------------------------------------- 78 !! 79 !! *** lbc_lnk_call_[234]d_[sd]p *** 80 !! *** load_ptr_[234]d_[sd]p *** 81 !! 82 !!---------------------------------------------------------------------- 110 83 !! 111 84 !! ---- SINGLE PRECISION VERSIONS 112 85 !! 113 # define SINGLE_PRECISION 114 # define DIM_2d 115 # define ROUTINE_LOAD load_ptr_2d_sp 116 # define ROUTINE_MULTI lbc_lnk_2d_multi_sp 117 # include "lbc_lnk_multi_generic.h90" 118 # undef ROUTINE_MULTI 119 # undef ROUTINE_LOAD 120 # undef DIM_2d 121 122 # define DIM_3d 123 # define ROUTINE_LOAD load_ptr_3d_sp 124 # define ROUTINE_MULTI lbc_lnk_3d_multi_sp 125 # include "lbc_lnk_multi_generic.h90" 126 # undef ROUTINE_MULTI 127 # undef ROUTINE_LOAD 128 # undef DIM_3d 129 130 # define DIM_4d 131 # define ROUTINE_LOAD load_ptr_4d_sp 132 # define ROUTINE_MULTI lbc_lnk_4d_multi_sp 133 # include "lbc_lnk_multi_generic.h90" 134 # undef ROUTINE_MULTI 135 # undef ROUTINE_LOAD 136 # undef DIM_4d 137 # undef SINGLE_PRECISION 86 #define PRECISION sp 87 # define DIM_2d 88 # include "lbc_lnk_call_generic.h90" 89 # undef DIM_2d 90 # define DIM_3d 91 # include "lbc_lnk_call_generic.h90" 92 # undef DIM_3d 93 # define DIM_4d 94 # include "lbc_lnk_call_generic.h90" 95 # undef DIM_4d 96 #undef PRECISION 138 97 !! 139 98 !! ---- DOUBLE PRECISION VERSIONS 140 99 !! 141 142 # define DIM_2d 143 # define ROUTINE_LOAD load_ptr_2d_dp 144 # define ROUTINE_MULTI lbc_lnk_2d_multi_dp 145 # include "lbc_lnk_multi_generic.h90" 146 # undef ROUTINE_MULTI 147 # undef ROUTINE_LOAD 148 # undef DIM_2d 149 150 # define DIM_3d 151 # define ROUTINE_LOAD load_ptr_3d_dp 152 # define ROUTINE_MULTI lbc_lnk_3d_multi_dp 153 # include "lbc_lnk_multi_generic.h90" 154 # undef ROUTINE_MULTI 155 # undef ROUTINE_LOAD 156 # undef DIM_3d 157 158 # define DIM_4d 159 # define ROUTINE_LOAD load_ptr_4d_dp 160 # define ROUTINE_MULTI lbc_lnk_4d_multi_dp 161 # include "lbc_lnk_multi_generic.h90" 162 # undef ROUTINE_MULTI 163 # undef ROUTINE_LOAD 164 # undef DIM_4d 165 166 !!---------------------------------------------------------------------- 167 !! *** routine mpp_lnk_(2,3,4)d *** 168 !! 169 !! * Argument : dummy argument use in mpp_lnk_... routines 170 !! ptab : array or pointer of arrays on which the boundary condition is applied 100 #define PRECISION dp 101 # define DIM_2d 102 # include "lbc_lnk_call_generic.h90" 103 # undef DIM_2d 104 # define DIM_3d 105 # include "lbc_lnk_call_generic.h90" 106 # undef DIM_3d 107 # define DIM_4d 108 # include "lbc_lnk_call_generic.h90" 109 # undef DIM_4d 110 #undef PRECISION 111 ! 112 !!---------------------------------------------------------------------- 113 !! *** lbc_lnk_pt2pt_[234]d_[sd]p *** 114 !! *** lbc_lnk_neicoll_[234]d_[sd]p *** 115 !! 116 !! * Argument : dummy argument use in lbc_lnk_... routines 117 !! cdname : name of the calling subroutine (for monitoring) 118 !! ptab : pointer of arrays on which the boundary condition is applied 171 119 !! cd_nat : nature of array grid-points 172 120 !! psgn : sign used across the north fold boundary 173 !! kfld : optional,number of pt3d arrays121 !! kfld : number of pt3d arrays 174 122 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 175 123 !! pfillval : optional, background value (used with jpfillcopy) 176 124 !!---------------------------------------------------------------------- 177 !178 ! !== 2D array and array of 2D pointer ==!179 !180 125 !! 181 126 !! ---- SINGLE PRECISION VERSIONS 182 127 !! 183 # define SINGLE_PRECISION 184 # define DIM_2d 185 # define ROUTINE_LNK mpp_lnk_2d_sp 186 # include "mpp_lnk_generic.h90" 187 # undef ROUTINE_LNK 188 # define MULTI 189 # define ROUTINE_LNK mpp_lnk_2d_ptr_sp 190 # include "mpp_lnk_generic.h90" 191 # undef ROUTINE_LNK 192 # undef MULTI 193 # undef DIM_2d 194 ! 195 ! !== 3D array and array of 3D pointer ==! 196 ! 197 # define DIM_3d 198 # define ROUTINE_LNK mpp_lnk_3d_sp 199 # include "mpp_lnk_generic.h90" 200 # undef ROUTINE_LNK 201 # define MULTI 202 # define ROUTINE_LNK mpp_lnk_3d_ptr_sp 203 # include "mpp_lnk_generic.h90" 204 # undef ROUTINE_LNK 205 # undef MULTI 206 # undef DIM_3d 207 ! 208 ! !== 4D array and array of 4D pointer ==! 209 ! 210 # define DIM_4d 211 # define ROUTINE_LNK mpp_lnk_4d_sp 212 # include "mpp_lnk_generic.h90" 213 # undef ROUTINE_LNK 214 # define MULTI 215 # define ROUTINE_LNK mpp_lnk_4d_ptr_sp 216 # include "mpp_lnk_generic.h90" 217 # undef ROUTINE_LNK 218 # undef MULTI 219 # undef DIM_4d 220 # undef SINGLE_PRECISION 221 128 #define PRECISION sp 129 # define MPI_TYPE MPI_REAL 130 # define DIM_2d 131 # include "lbc_lnk_pt2pt_generic.h90" 132 # include "lbc_lnk_neicoll_generic.h90" 133 # undef DIM_2d 134 # define DIM_3d 135 # include "lbc_lnk_pt2pt_generic.h90" 136 # include "lbc_lnk_neicoll_generic.h90" 137 # undef DIM_3d 138 # define DIM_4d 139 # include "lbc_lnk_pt2pt_generic.h90" 140 # include "lbc_lnk_neicoll_generic.h90" 141 # undef DIM_4d 142 # undef MPI_TYPE 143 #undef PRECISION 222 144 !! 223 145 !! ---- DOUBLE PRECISION VERSIONS 224 146 !! 225 # define DIM_2d 226 # define ROUTINE_LNK mpp_lnk_2d_dp 227 # include "mpp_lnk_generic.h90" 228 # undef ROUTINE_LNK 229 # define MULTI 230 # define ROUTINE_LNK mpp_lnk_2d_ptr_dp 231 # include "mpp_lnk_generic.h90" 232 # undef ROUTINE_LNK 233 # undef MULTI 234 # undef DIM_2d 235 ! 236 ! !== 3D array and array of 3D pointer ==! 237 ! 238 # define DIM_3d 239 # define ROUTINE_LNK mpp_lnk_3d_dp 240 # include "mpp_lnk_generic.h90" 241 # undef ROUTINE_LNK 242 # define MULTI 243 # define ROUTINE_LNK mpp_lnk_3d_ptr_dp 244 # include "mpp_lnk_generic.h90" 245 # undef ROUTINE_LNK 246 # undef MULTI 247 # undef DIM_3d 248 ! 249 ! !== 4D array and array of 4D pointer ==! 250 ! 251 # define DIM_4d 252 # define ROUTINE_LNK mpp_lnk_4d_dp 253 # include "mpp_lnk_generic.h90" 254 # undef ROUTINE_LNK 255 # define MULTI 256 # define ROUTINE_LNK mpp_lnk_4d_ptr_dp 257 # include "mpp_lnk_generic.h90" 258 # undef ROUTINE_LNK 259 # undef MULTI 260 # undef DIM_4d 261 262 !!---------------------------------------------------------------------- 263 !! *** load_ptr_(2,3,4)d *** 264 !! 265 !! * Dummy Argument : 266 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 267 !! cd_nat ! nature of pt2d array grid-points 268 !! psgn ! sign used across the north fold boundary 269 !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers 270 !! cdna_ptr ! nature of ptab array grid-points 271 !! psgn_ptr ! sign used across the north fold boundary 272 !! kfld ! number of elements that has been attributed 273 !!---------------------------------------------------------------------- 274 275 !!---------------------------------------------------------------------- 276 !! *** lbc_lnk_nc(2,3,4)d_multi *** 277 !! *** load_ptr_(2,3,4)d *** 278 !! 279 !! * Argument : dummy argument use in lbc_lnk_nc_multi_... routines 280 !! 281 !!---------------------------------------------------------------------- 282 283 !! 284 !! ---- SINGLE PRECISION VERSIONS 285 !! 286 # define SINGLE_PRECISION 287 # define DIM_2d 288 # define ROUTINE_NC_LOAD load_ptr_nc_2d_sp 289 # define ROUTINE_MULTI_NC lbc_lnk_nc_2d_sp 290 # include "lbc_lnk_nc_generic.h90" 291 # undef ROUTINE_MULTI_NC 292 # undef ROUTINE_NC_LOAD 293 # undef DIM_2d 294 295 # define DIM_3d 296 # define ROUTINE_NC_LOAD load_ptr_nc_3d_sp 297 # define ROUTINE_MULTI_NC lbc_lnk_nc_3d_sp 298 # include "lbc_lnk_nc_generic.h90" 299 # undef ROUTINE_MULTI_NC 300 # undef ROUTINE_NC_LOAD 301 # undef DIM_3d 302 303 # define DIM_4d 304 # define ROUTINE_NC_LOAD load_ptr_nc_4d_sp 305 # define ROUTINE_MULTI_NC lbc_lnk_nc_4d_sp 306 # include "lbc_lnk_nc_generic.h90" 307 # undef ROUTINE_MULTI_NC 308 # undef ROUTINE_NC_LOAD 309 # undef DIM_4d 310 # undef SINGLE_PRECISION 311 !! 312 !! ---- DOUBLE PRECISION VERSIONS 313 !! 314 315 # define DIM_2d 316 # define ROUTINE_NC_LOAD load_ptr_nc_2d_dp 317 # define ROUTINE_MULTI_NC lbc_lnk_nc_2d_dp 318 # include "lbc_lnk_nc_generic.h90" 319 # undef ROUTINE_MULTI_NC 320 # undef ROUTINE_NC_LOAD 321 # undef DIM_2d 322 323 # define DIM_3d 324 # define ROUTINE_NC_LOAD load_ptr_nc_3d_dp 325 # define ROUTINE_MULTI_NC lbc_lnk_nc_3d_dp 326 # include "lbc_lnk_nc_generic.h90" 327 # undef ROUTINE_MULTI_NC 328 # undef ROUTINE_NC_LOAD 329 # undef DIM_3d 330 331 # define DIM_4d 332 # define ROUTINE_NC_LOAD load_ptr_nc_4d_dp 333 # define ROUTINE_MULTI_NC lbc_lnk_nc_4d_dp 334 # include "lbc_lnk_nc_generic.h90" 335 # undef ROUTINE_MULTI_NC 336 # undef ROUTINE_NC_LOAD 337 # undef DIM_4d 338 339 !!---------------------------------------------------------------------- 340 !! *** routine mpp_lnk_nc_(2,3,4)d *** 341 !! 342 !! * Argument : dummy argument use in mpp_lnk_... routines 343 !! ptab : array or pointer of arrays on which the boundary condition is applied 344 !! cd_nat : nature of array grid-points 345 !! psgn : sign used across the north fold boundary 346 !! kfld : optional, number of pt3d arrays 347 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 348 !! pfillval : optional, background value (used with jpfillcopy) 349 !!---------------------------------------------------------------------- 350 ! 351 ! !== 2D array and array of 2D pointer ==! 352 ! 353 !! 354 !! ---- SINGLE PRECISION VERSIONS 355 !! 356 # define SINGLE_PRECISION 357 # define DIM_2d 358 # define ROUTINE_NC mpp_lnk_nc_2d_sp 359 # include "mpp_nc_generic.h90" 360 # undef ROUTINE_NC 361 # undef DIM_2d 362 ! 363 ! !== 3D array and array of 3D pointer ==! 364 ! 365 # define DIM_3d 366 # define ROUTINE_NC mpp_lnk_nc_3d_sp 367 # include "mpp_nc_generic.h90" 368 # undef ROUTINE_NC 369 # undef DIM_3d 370 ! 371 ! !== 4D array and array of 4D pointer ==! 372 ! 373 # define DIM_4d 374 # define ROUTINE_NC mpp_lnk_nc_4d_sp 375 # include "mpp_nc_generic.h90" 376 # undef ROUTINE_NC 377 # undef DIM_4d 378 # undef SINGLE_PRECISION 379 380 !! 381 !! ---- DOUBLE PRECISION VERSIONS 382 !! 383 # define DIM_2d 384 # define ROUTINE_NC mpp_lnk_nc_2d_dp 385 # include "mpp_nc_generic.h90" 386 # undef ROUTINE_NC 387 # undef DIM_2d 388 ! 389 ! !== 3D array and array of 3D pointer ==! 390 ! 391 # define DIM_3d 392 # define ROUTINE_NC mpp_lnk_nc_3d_dp 393 # include "mpp_nc_generic.h90" 394 # undef ROUTINE_NC 395 # undef DIM_3d 396 ! 397 ! !== 4D array and array of 4D pointer ==! 398 ! 399 # define DIM_4d 400 # define ROUTINE_NC mpp_lnk_nc_4d_dp 401 # include "mpp_nc_generic.h90" 402 # undef ROUTINE_NC 403 # undef DIM_4d 404 405 !!---------------------------------------------------------------------- 406 !! *** routine mpp_nfd_(2,3,4)d *** 407 !! 408 !! * Argument : dummy argument use in mpp_nfd_... routines 409 !! ptab : array or pointer of arrays on which the boundary condition is applied 410 !! cd_nat : nature of array grid-points 411 !! psgn : sign used across the north fold boundary 412 !! kfld : optional, number of pt3d arrays 413 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 414 !! pfillval : optional, background value (used with jpfillcopy) 415 !!---------------------------------------------------------------------- 416 ! 417 ! !== 2D array and array of 2D pointer ==! 418 ! 419 !! 420 !! ---- SINGLE PRECISION VERSIONS 421 !! 422 # define SINGLE_PRECISION 423 # define DIM_2d 424 # define ROUTINE_NFD mpp_nfd_2d_sp 425 # include "mpp_nfd_generic.h90" 426 # undef ROUTINE_NFD 427 # define MULTI 428 # define ROUTINE_NFD mpp_nfd_2d_ptr_sp 429 # include "mpp_nfd_generic.h90" 430 # undef ROUTINE_NFD 431 # undef MULTI 432 # undef DIM_2d 433 ! 434 ! !== 3D array and array of 3D pointer ==! 435 ! 436 # define DIM_3d 437 # define ROUTINE_NFD mpp_nfd_3d_sp 438 # include "mpp_nfd_generic.h90" 439 # undef ROUTINE_NFD 440 # define MULTI 441 # define ROUTINE_NFD mpp_nfd_3d_ptr_sp 442 # include "mpp_nfd_generic.h90" 443 # undef ROUTINE_NFD 444 # undef MULTI 445 # undef DIM_3d 446 ! 447 ! !== 4D array and array of 4D pointer ==! 448 ! 449 # define DIM_4d 450 # define ROUTINE_NFD mpp_nfd_4d_sp 451 # include "mpp_nfd_generic.h90" 452 # undef ROUTINE_NFD 453 # define MULTI 454 # define ROUTINE_NFD mpp_nfd_4d_ptr_sp 455 # include "mpp_nfd_generic.h90" 456 # undef ROUTINE_NFD 457 # undef MULTI 458 # undef DIM_4d 459 # undef SINGLE_PRECISION 460 461 !! 462 !! ---- DOUBLE PRECISION VERSIONS 463 !! 464 # define DIM_2d 465 # define ROUTINE_NFD mpp_nfd_2d_dp 466 # include "mpp_nfd_generic.h90" 467 # undef ROUTINE_NFD 468 # define MULTI 469 # define ROUTINE_NFD mpp_nfd_2d_ptr_dp 470 # include "mpp_nfd_generic.h90" 471 # undef ROUTINE_NFD 472 # undef MULTI 473 # undef DIM_2d 474 ! 475 ! !== 3D array and array of 3D pointer ==! 476 ! 477 # define DIM_3d 478 # define ROUTINE_NFD mpp_nfd_3d_dp 479 # include "mpp_nfd_generic.h90" 480 # undef ROUTINE_NFD 481 # define MULTI 482 # define ROUTINE_NFD mpp_nfd_3d_ptr_dp 483 # include "mpp_nfd_generic.h90" 484 # undef ROUTINE_NFD 485 # undef MULTI 486 # undef DIM_3d 487 ! 488 ! !== 4D array and array of 4D pointer ==! 489 ! 490 # define DIM_4d 491 # define ROUTINE_NFD mpp_nfd_4d_dp 492 # include "mpp_nfd_generic.h90" 493 # undef ROUTINE_NFD 494 # define MULTI 495 # define ROUTINE_NFD mpp_nfd_4d_ptr_dp 496 # include "mpp_nfd_generic.h90" 497 # undef ROUTINE_NFD 498 # undef MULTI 499 # undef DIM_4d 500 501 !!====================================================================== 502 147 #define PRECISION dp 148 # define MPI_TYPE MPI_DOUBLE_PRECISION 149 # define DIM_2d 150 # include "lbc_lnk_pt2pt_generic.h90" 151 # include "lbc_lnk_neicoll_generic.h90" 152 # undef DIM_2d 153 # define DIM_3d 154 # include "lbc_lnk_pt2pt_generic.h90" 155 # include "lbc_lnk_neicoll_generic.h90" 156 # undef DIM_3d 157 # define DIM_4d 158 # include "lbc_lnk_pt2pt_generic.h90" 159 # include "lbc_lnk_neicoll_generic.h90" 160 # undef DIM_4d 161 # undef MPI_TYPE 162 #undef PRECISION 503 163 504 164 !!====================================================================== -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbcnfd.F90
r13286 r14338 21 21 USE in_out_manager ! I/O manager 22 22 USE lib_mpp ! MPP library 23 #if ! defined key_mpi_off 24 USE MPI 25 #endif 23 26 24 27 IMPLICIT NONE 25 28 PRIVATE 26 29 27 INTERFACE lbc_nfd 28 MODULE PROCEDURE lbc_nfd_2d_sp , lbc_nfd_3d_sp , lbc_nfd_4d_sp 29 MODULE PROCEDURE lbc_nfd_2d_ptr_sp, lbc_nfd_3d_ptr_sp, lbc_nfd_4d_ptr_sp 30 MODULE PROCEDURE lbc_nfd_2d_ext_sp 31 MODULE PROCEDURE lbc_nfd_2d_dp , lbc_nfd_3d_dp , lbc_nfd_4d_dp 32 MODULE PROCEDURE lbc_nfd_2d_ptr_dp, lbc_nfd_3d_ptr_dp, lbc_nfd_4d_ptr_dp 33 MODULE PROCEDURE lbc_nfd_2d_ext_dp 34 END INTERFACE 35 ! 36 INTERFACE lbc_nfd_nogather 37 ! ! Currently only 4d array version is needed 38 MODULE PROCEDURE lbc_nfd_nogather_2d_sp , lbc_nfd_nogather_3d_sp 39 MODULE PROCEDURE lbc_nfd_nogather_4d_sp 40 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_sp, lbc_nfd_nogather_3d_ptr_sp 41 MODULE PROCEDURE lbc_nfd_nogather_2d_dp , lbc_nfd_nogather_3d_dp 42 MODULE PROCEDURE lbc_nfd_nogather_4d_dp 43 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_dp, lbc_nfd_nogather_3d_ptr_dp 44 ! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr 30 INTERFACE lbc_nfd ! called by mpp_nfd, lbc_lnk_pt2pt, lbc_lnk_neicoll 31 MODULE PROCEDURE lbc_nfd_2d_sp, lbc_nfd_ext_2d_sp, lbc_nfd_3d_sp, lbc_nfd_4d_sp 32 MODULE PROCEDURE lbc_nfd_2d_dp, lbc_nfd_ext_2d_dp, lbc_nfd_3d_dp, lbc_nfd_4d_dp 45 33 END INTERFACE 46 34 47 TYPE, PUBLIC :: PTR_2D_dp !: array of 2D pointers (also used in lib_mpp) 48 REAL(dp), DIMENSION (:,:) , POINTER :: pt2d 49 END TYPE PTR_2D_dp 50 TYPE, PUBLIC :: PTR_3D_dp !: array of 3D pointers (also used in lib_mpp) 51 REAL(dp), DIMENSION (:,:,:) , POINTER :: pt3d 52 END TYPE PTR_3D_dp 53 TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (also used in lib_mpp) 54 REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d 55 END TYPE PTR_4D_dp 35 INTERFACE lbc_nfd_nogather ! called by mpp_nfd 36 MODULE PROCEDURE lbc_nfd_nogather_2d_sp, lbc_nfd_nogather_3d_sp, lbc_nfd_nogather_4d_sp 37 MODULE PROCEDURE lbc_nfd_nogather_2d_dp, lbc_nfd_nogather_3d_dp, lbc_nfd_nogather_4d_dp 38 END INTERFACE 56 39 57 TYPE, PUBLIC :: PTR_2D_sp !: array of 2D pointers (also used in lib_mpp) 58 REAL(sp), DIMENSION (:,:) , POINTER :: pt2d 59 END TYPE PTR_2D_sp 60 TYPE, PUBLIC :: PTR_3D_sp !: array of 3D pointers (also used in lib_mpp) 61 REAL(sp), DIMENSION (:,:,:) , POINTER :: pt3d 62 END TYPE PTR_3D_sp 63 TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (also used in lib_mpp) 64 REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d 65 END TYPE PTR_4D_sp 66 67 40 INTERFACE mpp_nfd 41 MODULE PROCEDURE mpp_nfd_2d_sp, mpp_nfd_3d_sp, mpp_nfd_4d_sp 42 MODULE PROCEDURE mpp_nfd_2d_dp, mpp_nfd_3d_dp, mpp_nfd_4d_dp 43 END INTERFACE 44 45 PUBLIC mpp_nfd ! mpi north fold conditions 68 46 PUBLIC lbc_nfd ! north fold conditions 69 47 PUBLIC lbc_nfd_nogather ! north fold conditions (no allgather case) … … 82 60 83 61 !!---------------------------------------------------------------------- 84 !! *** routine lbc_nfd_(2,3,4)d *** 62 !! *** routine lbc_nfd_[234]d_[sd]p *** 63 !! *** routine lbc_nfd_nogather_[234]d_[sd]p *** 64 !! *** routine lbc_nfd_ext_2d_[sd]p *** 85 65 !!---------------------------------------------------------------------- 86 66 !! … … 95 75 ! !== SINGLE PRECISION VERSIONS 96 76 ! 97 ! 98 ! !== 2D array and array of 2D pointer ==! 99 ! 100 # define SINGLE_PRECISION 101 # define DIM_2d 102 # define ROUTINE_NFD lbc_nfd_2d_sp 103 # include "lbc_nfd_generic.h90" 104 # undef ROUTINE_NFD 105 # define MULTI 106 # define ROUTINE_NFD lbc_nfd_2d_ptr_sp 107 # include "lbc_nfd_generic.h90" 108 # undef ROUTINE_NFD 109 # undef MULTI 110 # undef DIM_2d 111 ! 112 ! !== 2D array with extra haloes ==! 113 ! 114 # define DIM_2d 115 # define ROUTINE_NFD lbc_nfd_2d_ext_sp 116 # include "lbc_nfd_ext_generic.h90" 117 # undef ROUTINE_NFD 118 # undef DIM_2d 119 ! 120 ! !== 3D array and array of 3D pointer ==! 121 ! 122 # define DIM_3d 123 # define ROUTINE_NFD lbc_nfd_3d_sp 124 # include "lbc_nfd_generic.h90" 125 # undef ROUTINE_NFD 126 # define MULTI 127 # define ROUTINE_NFD lbc_nfd_3d_ptr_sp 128 # include "lbc_nfd_generic.h90" 129 # undef ROUTINE_NFD 130 # undef MULTI 131 # undef DIM_3d 132 ! 133 ! !== 4D array and array of 4D pointer ==! 134 ! 135 # define DIM_4d 136 # define ROUTINE_NFD lbc_nfd_4d_sp 137 # include "lbc_nfd_generic.h90" 138 # undef ROUTINE_NFD 139 # define MULTI 140 # define ROUTINE_NFD lbc_nfd_4d_ptr_sp 141 # include "lbc_nfd_generic.h90" 142 # undef ROUTINE_NFD 143 # undef MULTI 144 # undef DIM_4d 145 ! 146 ! lbc_nfd_nogather routines 147 ! 148 ! !== 2D array and array of 2D pointer ==! 149 ! 150 # define DIM_2d 151 # define ROUTINE_NFD lbc_nfd_nogather_2d_sp 152 # include "lbc_nfd_nogather_generic.h90" 153 # undef ROUTINE_NFD 154 # define MULTI 155 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_sp 156 # include "lbc_nfd_nogather_generic.h90" 157 # undef ROUTINE_NFD 158 # undef MULTI 159 # undef DIM_2d 160 ! 161 ! !== 3D array and array of 3D pointer ==! 162 ! 163 # define DIM_3d 164 # define ROUTINE_NFD lbc_nfd_nogather_3d_sp 165 # include "lbc_nfd_nogather_generic.h90" 166 # undef ROUTINE_NFD 167 # define MULTI 168 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_sp 169 # include "lbc_nfd_nogather_generic.h90" 170 # undef ROUTINE_NFD 171 # undef MULTI 172 # undef DIM_3d 173 ! 174 ! !== 4D array and array of 4D pointer ==! 175 ! 176 # define DIM_4d 177 # define ROUTINE_NFD lbc_nfd_nogather_4d_sp 178 # include "lbc_nfd_nogather_generic.h90" 179 # undef ROUTINE_NFD 180 !# define MULTI 181 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr 182 !# include "lbc_nfd_nogather_generic.h90" 183 !# undef ROUTINE_NFD 184 !# undef MULTI 185 # undef DIM_4d 186 # undef SINGLE_PRECISION 187 188 !!---------------------------------------------------------------------- 77 #define PRECISION sp 78 # define DIM_2d 79 # include "lbc_nfd_generic.h90" 80 # include "lbc_nfd_nogather_generic.h90" 81 # include "lbc_nfd_ext_generic.h90" 82 # undef DIM_2d 83 # define DIM_3d 84 # include "lbc_nfd_generic.h90" 85 # include "lbc_nfd_nogather_generic.h90" 86 # undef DIM_3d 87 # define DIM_4d 88 # include "lbc_nfd_generic.h90" 89 # include "lbc_nfd_nogather_generic.h90" 90 # undef DIM_4d 91 #undef PRECISION 189 92 ! 190 93 ! !== DOUBLE PRECISION VERSIONS 191 94 ! 95 #define PRECISION dp 96 # define DIM_2d 97 # include "lbc_nfd_generic.h90" 98 # include "lbc_nfd_nogather_generic.h90" 99 # include "lbc_nfd_ext_generic.h90" 100 # undef DIM_2d 101 # define DIM_3d 102 # include "lbc_nfd_generic.h90" 103 # include "lbc_nfd_nogather_generic.h90" 104 # undef DIM_3d 105 # define DIM_4d 106 # include "lbc_nfd_generic.h90" 107 # include "lbc_nfd_nogather_generic.h90" 108 # undef DIM_4d 109 #undef PRECISION 110 111 !!====================================================================== 192 112 ! 193 ! !== 2D array and array of 2D pointer ==!194 !195 # define DIM_2d196 # define ROUTINE_NFD lbc_nfd_2d_dp197 # include "lbc_nfd_generic.h90"198 # undef ROUTINE_NFD199 # define MULTI200 # define ROUTINE_NFD lbc_nfd_2d_ptr_dp201 # include "lbc_nfd_generic.h90"202 # undef ROUTINE_NFD203 # undef MULTI204 # undef DIM_2d205 !206 ! !== 2D array with extra haloes ==!207 !208 # define DIM_2d209 # define ROUTINE_NFD lbc_nfd_2d_ext_dp210 # include "lbc_nfd_ext_generic.h90"211 # undef ROUTINE_NFD212 # undef DIM_2d213 !214 ! !== 3D array and array of 3D pointer ==!215 !216 # define DIM_3d217 # define ROUTINE_NFD lbc_nfd_3d_dp218 # include "lbc_nfd_generic.h90"219 # undef ROUTINE_NFD220 # define MULTI221 # define ROUTINE_NFD lbc_nfd_3d_ptr_dp222 # include "lbc_nfd_generic.h90"223 # undef ROUTINE_NFD224 # undef MULTI225 # undef DIM_3d226 !227 ! !== 4D array and array of 4D pointer ==!228 !229 # define DIM_4d230 # define ROUTINE_NFD lbc_nfd_4d_dp231 # include "lbc_nfd_generic.h90"232 # undef ROUTINE_NFD233 # define MULTI234 # define ROUTINE_NFD lbc_nfd_4d_ptr_dp235 # include "lbc_nfd_generic.h90"236 # undef ROUTINE_NFD237 # undef MULTI238 # undef DIM_4d239 !240 ! lbc_nfd_nogather routines241 !242 ! !== 2D array and array of 2D pointer ==!243 !244 # define DIM_2d245 # define ROUTINE_NFD lbc_nfd_nogather_2d_dp246 # include "lbc_nfd_nogather_generic.h90"247 # undef ROUTINE_NFD248 # define MULTI249 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_dp250 # include "lbc_nfd_nogather_generic.h90"251 # undef ROUTINE_NFD252 # undef MULTI253 # undef DIM_2d254 !255 ! !== 3D array and array of 3D pointer ==!256 !257 # define DIM_3d258 # define ROUTINE_NFD lbc_nfd_nogather_3d_dp259 # include "lbc_nfd_nogather_generic.h90"260 # undef ROUTINE_NFD261 # define MULTI262 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_dp263 # include "lbc_nfd_nogather_generic.h90"264 # undef ROUTINE_NFD265 # undef MULTI266 # undef DIM_3d267 !268 ! !== 4D array and array of 4D pointer ==!269 !270 # define DIM_4d271 # define ROUTINE_NFD lbc_nfd_nogather_4d_dp272 # include "lbc_nfd_nogather_generic.h90"273 # undef ROUTINE_NFD274 !# define MULTI275 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr276 !# include "lbc_nfd_nogather_generic.h90"277 !# undef ROUTINE_NFD278 !# undef MULTI279 # undef DIM_4d280 281 113 !!---------------------------------------------------------------------- 282 283 114 !! *** routine mpp_nfd_(2,3,4)d *** 115 !! 116 !! * Argument : dummy argument use in mpp_nfd_... routines 117 !! ptab : pointer of arrays on which the boundary condition is applied 118 !! cd_nat : nature of array grid-points 119 !! psgn : sign used across the north fold boundary 120 !! kfld : optional, number of pt3d arrays 121 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 122 !! pfillval : optional, background value (used with jpfillcopy) 123 !!---------------------------------------------------------------------- 124 !! 125 !! ---- SINGLE PRECISION VERSIONS 126 !! 127 #define PRECISION sp 128 # define MPI_TYPE MPI_REAL 129 # define DIM_2d 130 # include "mpp_nfd_generic.h90" 131 # undef DIM_2d 132 # define DIM_3d 133 # include "mpp_nfd_generic.h90" 134 # undef DIM_3d 135 # define DIM_4d 136 # include "mpp_nfd_generic.h90" 137 # undef DIM_4d 138 # undef MPI_TYPE 139 #undef PRECISION 140 !! 141 !! ---- DOUBLE PRECISION VERSIONS 142 !! 143 #define PRECISION dp 144 # define MPI_TYPE MPI_DOUBLE_PRECISION 145 # define DIM_2d 146 # include "mpp_nfd_generic.h90" 147 # undef DIM_2d 148 # define DIM_3d 149 # include "mpp_nfd_generic.h90" 150 # undef DIM_3d 151 # define DIM_4d 152 # include "mpp_nfd_generic.h90" 153 # undef DIM_4d 154 # undef MPI_TYPE 155 #undef PRECISION 284 156 285 157 !!====================================================================== -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lib_mpp.F90
r14314 r14338 55 55 USE dom_oce ! ocean space and time domain 56 56 USE in_out_manager ! I/O manager 57 #if ! defined key_mpi_off 58 USE MPI 59 #endif 57 60 58 61 IMPLICIT NONE … … 107 110 END INTERFACE 108 111 112 TYPE, PUBLIC :: PTR_2D_sp !: array of 2D pointers (used in lbclnk and lbcnfd) 113 REAL(sp), DIMENSION (:,:) , POINTER :: pt2d 114 END TYPE PTR_2D_sp 115 TYPE, PUBLIC :: PTR_3D_sp !: array of 3D pointers (used in lbclnk and lbcnfd) 116 REAL(sp), DIMENSION (:,:,:) , POINTER :: pt3d 117 END TYPE PTR_3D_sp 118 TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (used in lbclnk and lbcnfd) 119 REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d 120 END TYPE PTR_4D_sp 121 122 TYPE, PUBLIC :: PTR_2D_dp !: array of 2D pointers (used in lbclnk and lbcnfd) 123 REAL(dp), DIMENSION (:,:) , POINTER :: pt2d 124 END TYPE PTR_2D_dp 125 TYPE, PUBLIC :: PTR_3D_dp !: array of 3D pointers (used in lbclnk and lbcnfd) 126 REAL(dp), DIMENSION (:,:,:) , POINTER :: pt3d 127 END TYPE PTR_3D_dp 128 TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (used in lbclnk and lbcnfd) 129 REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d 130 END TYPE PTR_4D_dp 131 109 132 !! ========================= !! 110 133 !! MPI variable definition !! 111 134 !! ========================= !! 112 135 #if ! defined key_mpi_off 113 !$AGRIF_DO_NOT_TREAT114 INCLUDE 'mpif.h'115 !$AGRIF_END_DO_NOT_TREAT116 136 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 117 137 #else … … 199 219 200 220 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 221 INTEGER, PUBLIC :: nn_comm !: namelist control of comms 222 223 INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 224 INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 225 INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 226 INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 227 INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 201 228 202 229 !! * Substitutions … … 276 303 INTEGER , INTENT(in ) :: kdest ! receive process number 277 304 INTEGER , INTENT(in ) :: ktyp ! tag of the message 278 INTEGER , INTENT(in 305 INTEGER , INTENT(inout) :: md_req ! argument for isend 279 306 !! 280 307 INTEGER :: iflag … … 305 332 INTEGER , INTENT(in ) :: kdest ! receive process number 306 333 INTEGER , INTENT(in ) :: ktyp ! tag of the message 307 INTEGER , INTENT(in 334 INTEGER , INTENT(inout) :: md_req ! argument for isend 308 335 !! 309 336 INTEGER :: iflag … … 328 355 INTEGER , INTENT(in ) :: kdest ! receive process number 329 356 INTEGER , INTENT(in ) :: ktyp ! tag of the message 330 INTEGER , INTENT(in 357 INTEGER , INTENT(inout) :: md_req ! argument for isend 331 358 !! 332 359 INTEGER :: iflag … … 955 982 LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number 956 983 LOGICAL :: ll_abort 957 INTEGER :: info 984 INTEGER :: info, ierr 958 985 !!---------------------------------------------------------------------- 959 986 ll_abort = .FALSE. … … 962 989 #if ! defined key_mpi_off 963 990 IF(ll_abort) THEN 964 CALL mpi_abort( MPI_COMM_WORLD )991 CALL mpi_abort( MPI_COMM_WORLD, 123, info ) 965 992 ELSE 966 993 CALL mppsync … … 975 1002 SUBROUTINE mpp_comm_free( kcom ) 976 1003 !!---------------------------------------------------------------------- 977 INTEGER, INTENT(in ) :: kcom1004 INTEGER, INTENT(inout) :: kcom 978 1005 !! 979 1006 INTEGER :: ierr -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mpp_nfd_generic.h90
r14336 r14338 1 #if defined MULTI 2 # define NAT_IN(k) cd_nat(k) 3 # define SGN_IN(k) psgn(k) 4 # define F_SIZE(ptab) kfld 5 # define LBC_ARG (jf) 6 # if defined DIM_2d 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 12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 13 # define K_SIZE(ptab) 1 14 # define L_SIZE(ptab) 1 15 # endif 16 # if defined DIM_3d 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 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 24 # define L_SIZE(ptab) 1 25 # endif 26 # if defined DIM_4d 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 32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 34 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 35 # endif 36 #else 37 ! !== IN: ptab is an array ==! 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 43 # define NAT_IN(k) cd_nat 44 # define SGN_IN(k) psgn 45 # define F_SIZE(ptab) 1 46 # define LBC_ARG 47 # if defined DIM_2d 48 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 49 # define K_SIZE(ptab) 1 50 # define L_SIZE(ptab) 1 51 # endif 52 # if defined DIM_3d 53 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) 54 # define K_SIZE(ptab) SIZE(ptab,3) 55 # define L_SIZE(ptab) 1 56 # endif 57 # if defined DIM_4d 58 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) 59 # define K_SIZE(ptab) SIZE(ptab,3) 60 # define L_SIZE(ptab) SIZE(ptab,4) 61 # endif 62 #endif 1 #if defined DIM_2d 2 # define XD 2d 3 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 4 # define ARRAY_LOCAL(i,j,k,l,f) zptr(f)%pt4d(i,j,1:1,1:1) 5 # define K_SIZE(ptab) 1 6 # define L_SIZE(ptab) 1 7 #endif 8 #if defined DIM_3d 9 # define XD 3d 10 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 11 # define ARRAY_LOCAL(i,j,k,l,f) zptr(f)%pt4d(i,j,k,1:1) 12 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 13 # define L_SIZE(ptab) 1 14 #endif 15 #if defined DIM_4d 16 # define XD 4d 17 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 18 # define ARRAY_LOCAL(i,j,k,l,f) zptr(f)%pt4d(i,j,k,l) 19 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 20 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 21 #endif 22 #define F_SIZE(ptab) kfld 63 23 64 # if defined SINGLE_PRECISION 65 # define PRECISION sp 66 # define SENDROUTINE mppsend_sp 67 # define RECVROUTINE mpprecv_sp 68 # define MPI_TYPE MPI_REAL 69 # define HUGEVAL(x) HUGE(x/**/_sp) 70 # else 71 # define PRECISION dp 72 # define SENDROUTINE mppsend_dp 73 # define RECVROUTINE mpprecv_dp 74 # define MPI_TYPE MPI_DOUBLE_PRECISION 75 # define HUGEVAL(x) HUGE(x/**/_dp) 76 # endif 77 78 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 79 !!---------------------------------------------------------------------- 80 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 83 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 84 REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 24 SUBROUTINE mpp_nfd_/**/XD/**/_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 25 TYPE(PTR_/**/XD/**/_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 26 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 27 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary 28 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 29 REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 30 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 86 31 ! 87 32 LOGICAL :: ll_add_line … … 95 40 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 96 41 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 97 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather98 42 ! ! Workspace for message transfers avoiding mpi_allgather 99 43 INTEGER :: ipj_b ! sum of lines for all multi fields … … 103 47 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 104 48 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 105 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: z tabglo, znorthloc49 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc 106 50 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo 51 TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c. 107 52 !!---------------------------------------------------------------------- 108 53 ! … … 141 86 IF( ll_add_line ) THEN 142 87 DO jf = 1, ipf ! Loop over the number of arrays to be processed 143 ipj_s(jf) = nn_hls + COUNT( (/ c_NFtype == 'T' .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) )88 ipj_s(jf) = nn_hls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) 144 89 END DO 145 90 ELSE … … 156 101 ! 157 102 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 158 SELECT CASE ( NAT_IN(jf) )103 SELECT CASE ( cd_nat(jf) ) 159 104 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 160 105 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point … … 162 107 ENDIF 163 108 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 164 SELECT CASE ( NAT_IN(jf) )109 SELECT CASE ( cd_nat(jf) ) 165 110 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 166 111 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point … … 187 132 END DO 188 133 DO ji = jpi+1, jpimax 189 ztabb(ji,ij1,jk,jl) = HUGE VAL(0.) ! avoid sending uninitialized values (make sure we don't use it)134 ztabb(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it) 190 135 END DO 191 136 END DO … … 199 144 iproc = nfproc(isendto(jr)) 200 145 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 201 CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 146 #if ! defined key_mpi_off 147 CALL MPI_ISEND( ztabb, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ml_req_nf(jr), ierr ) 148 #endif 202 149 ENDIF 203 150 END DO … … 258 205 ELSE ! get data from a neighbour trough communication 259 206 ! 260 CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 207 #if ! defined key_mpi_off 208 CALL MPI_RECV( ztabw, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, MPI_STATUS_IGNORE, ierr ) 209 #endif 261 210 DO jl = 1, ipl ; DO jk = 1, ipk 262 211 DO jj = 1, ipj_b … … 278 227 ij1 = jj_b( 1 ,jf) 279 228 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)229 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf) ) 281 230 END DO 282 231 ! … … 286 235 iproc = nfproc(isendto(jr)) 287 236 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 288 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate237 CALL mpi_wait( ml_req_nf(jr), MPI_STATUS_IGNORE, ml_err ) ! put the wait at the very end just before the deallocate 289 238 ENDIF 290 239 END DO … … 310 259 END DO 311 260 DO ji = Ni_0+1, i0max 312 znorthloc(ji,jj,jk,jl,jf) = HUGE VAL(0.) ! avoid sending uninitialized values (make sure we don't use it)261 znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it) 313 262 END DO 314 263 END DO … … 323 272 IF( ln_timing ) CALL tic_tac(.FALSE.) 324 273 DEALLOCATE( znorthloc ) 325 ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) ) 274 ALLOCATE( ztabglo(ipf) ) 275 DO jf = 1, ipf 276 ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) ) 277 END DO 326 278 ! 327 279 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines … … 341 293 DO ji = 1, ipi 342 294 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 point295 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 344 296 END DO 345 297 END DO … … 350 302 DO ji = 1, ipi 351 303 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 352 ztabglo( ii1,jj,jk,jl,jf) = pfillval304 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval 353 305 END DO 354 306 END DO … … 362 314 DO ji = 1, ipi 363 315 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)316 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr) 365 317 END DO 366 318 END DO … … 372 324 ! 373 325 DO jf = 1, ipf 374 CALL lbc_nfd( ztabglo( :,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG) ! North fold boundary condition326 CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), 1 ) ! North fold boundary condition 375 327 DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity 376 328 DO jj = 1, nn_hls + 1 377 329 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(j piglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf)330 ztabglo(jf)%pt4d( 1:nn_hls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl) 331 ztabglo(jf)%pt4d(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( nn_hls+1: 2*nn_hls,ij1,jk,jl) 380 332 END DO 381 333 END DO ; END DO … … 388 340 DO ji= 1, jpi 389 341 ii2 = mig(ji) 390 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo( ii2,ij2,jk,jl,jf)342 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl) 391 343 END DO 392 344 END DO 393 345 END DO ; END DO ; END DO 394 346 ! 347 DO jf = 1, ipf 348 DEALLOCATE( ztabglo(jf)%pt4d ) 349 END DO 395 350 DEALLOCATE( ztabglo ) 396 351 ! 397 352 ENDIF ! l_north_nogather 398 353 ! 399 END SUBROUTINE ROUTINE_NFD354 END SUBROUTINE mpp_nfd_/**/XD/**/_/**/PRECISION 400 355 401 #undef PRECISION 402 #undef MPI_TYPE 403 #undef SENDROUTINE 404 #undef RECVROUTINE 405 #undef ARRAY_TYPE 406 #undef NAT_IN 407 #undef SGN_IN 356 #undef XD 408 357 #undef ARRAY_IN 358 #undef ARRAY_LOCAL 409 359 #undef K_SIZE 410 360 #undef L_SIZE 411 361 #undef F_SIZE 412 #undef LBC_ARG413 #undef HUGEVAL -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mppini.F90
r14336 r14338 145 145 & cn_ice, nn_ice_dta, & 146 146 & ln_vol, nn_volctl, nn_rimwidth 147 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 147 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly, nn_comm 148 148 !!---------------------------------------------------------------------- 149 149 !
Note: See TracChangeset
for help on using the changeset viewer.
