Changeset 11536 for NEMO/trunk/src/OCE/LBC
- Timestamp:
- 2019-09-11T15:54:18+02:00 (5 years ago)
- Location:
- NEMO/trunk/src/OCE/LBC
- Files:
-
- 2 deleted
- 8 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk/src/OCE/LBC/lbc_lnk_multi_generic.h90
r10425 r11536 14 14 # define PTR_ptab pt4d 15 15 #endif 16 SUBROUTINE ROUTINE_MULTI( cdname & 17 & , pt1, cdna1, psgn1, pt2, cdna2, psgn2, pt3, cdna3, psgn3 & 18 & , pt4, cdna4, psgn4, pt5, cdna5, psgn5, pt6, cdna6, psgn6 & 19 & , pt7, cdna7, psgn7, pt8, cdna8, psgn8, pt9, cdna9, psgn9, cd_mpp, pval) 16 17 SUBROUTINE ROUTINE_MULTI( cdname & 18 & , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4 & 19 & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 & 20 & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 & 21 & , kfillmode, pfillval, lsend, lrecv, ihlcom ) 20 22 !!--------------------------------------------------------------------- 21 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 22 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 23 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 24 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 25 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9 26 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 27 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9 28 CHARACTER(len=3) , OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 29 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 23 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 24 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 25 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , pt10 , pt11 26 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 27 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 28 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 29 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 30 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 31 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 32 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 33 INTEGER , OPTIONAL , INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated 30 34 !! 31 INTEGER :: kfld ! number of elements that will be attributed32 PTR_TYPE , DIMENSION( 9) :: ptab_ptr ! pointer array33 CHARACTER(len=1) , DIMENSION( 9) :: cdna_ptr ! nature of ptab_ptr grid-points34 REAL(wp) , DIMENSION( 9) :: psgn_ptr ! sign used across the north fold boundary35 INTEGER :: kfld ! number of elements that will be attributed 36 PTR_TYPE , DIMENSION(11) :: ptab_ptr ! pointer array 37 CHARACTER(len=1) , DIMENSION(11) :: cdna_ptr ! nature of ptab_ptr grid-points 38 REAL(wp) , DIMENSION(11) :: psgn_ptr ! sign used across the north fold boundary 35 39 !!--------------------------------------------------------------------- 36 40 ! … … 41 45 ! 42 46 ! ! Look if more arrays are added 43 IF( PRESENT(psgn2) ) CALL ROUTINE_LOAD( pt2, cdna2, psgn2, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 44 IF( PRESENT(psgn3) ) CALL ROUTINE_LOAD( pt3, cdna3, psgn3, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 45 IF( PRESENT(psgn4) ) CALL ROUTINE_LOAD( pt4, cdna4, psgn4, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 46 IF( PRESENT(psgn5) ) CALL ROUTINE_LOAD( pt5, cdna5, psgn5, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 47 IF( PRESENT(psgn6) ) CALL ROUTINE_LOAD( pt6, cdna6, psgn6, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 48 IF( PRESENT(psgn7) ) CALL ROUTINE_LOAD( pt7, cdna7, psgn7, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 49 IF( PRESENT(psgn8) ) CALL ROUTINE_LOAD( pt8, cdna8, psgn8, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 50 IF( PRESENT(psgn9) ) CALL ROUTINE_LOAD( pt9, cdna9, psgn9, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 47 IF( PRESENT(psgn2 ) ) CALL ROUTINE_LOAD( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 48 IF( PRESENT(psgn3 ) ) CALL ROUTINE_LOAD( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 49 IF( PRESENT(psgn4 ) ) CALL ROUTINE_LOAD( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 50 IF( PRESENT(psgn5 ) ) CALL ROUTINE_LOAD( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 51 IF( PRESENT(psgn6 ) ) CALL ROUTINE_LOAD( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 52 IF( PRESENT(psgn7 ) ) CALL ROUTINE_LOAD( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 53 IF( PRESENT(psgn8 ) ) CALL ROUTINE_LOAD( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 54 IF( PRESENT(psgn9 ) ) CALL ROUTINE_LOAD( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 55 IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 56 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 51 57 ! 52 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, cd_mpp, pval)58 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 53 59 ! 54 60 END SUBROUTINE ROUTINE_MULTI … … 72 78 ! 73 79 END SUBROUTINE ROUTINE_LOAD 80 74 81 #undef ARRAY_TYPE 75 82 #undef PTR_TYPE -
NEMO/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r10425 r11536 74 74 ! 75 75 ! Security check for further developments 76 IF ( ipf > 1 ) THEN 77 write(6,*) 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation' 78 write(6,*) 'You should not be there...' 79 STOP 80 ENDIF 76 IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 81 77 ! 82 78 ijpj = 1 ! index of first modified line -
NEMO/trunk/src/OCE/LBC/lbclnk.F90
r10425 r11536 14 14 !! - ! 2017-05 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 15 15 !!---------------------------------------------------------------------- 16 #if defined key_mpp_mpi17 !!----------------------------------------------------------------------18 !! 'key_mpp_mpi' MPI massively parallel processing library19 !!----------------------------------------------------------------------20 16 !! define the generic interfaces of lib_mpp routines 21 17 !!---------------------------------------------------------------------- … … 23 19 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 24 20 !!---------------------------------------------------------------------- 25 USE par_oce ! ocean dynamics and tracers21 USE dom_oce ! ocean space and time domain 26 22 USE lib_mpp ! distributed memory computing library 27 23 USE lbcnfd ! north fold 24 USE in_out_manager ! I/O manager 25 26 IMPLICIT NONE 27 PRIVATE 28 28 29 29 INTERFACE lbc_lnk … … 37 37 END INTERFACE 38 38 ! 39 INTERFACE lbc_bdy_lnk40 MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d41 END INTERFACE42 !43 39 INTERFACE lbc_lnk_icb 44 40 MODULE PROCEDURE mpp_lnk_2d_icb 45 41 END INTERFACE 46 42 43 INTERFACE mpp_nfd 44 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 45 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 46 END INTERFACE 47 47 48 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 48 49 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 49 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions50 50 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 51 52 #if defined key_mpp_mpi 53 !$AGRIF_DO_NOT_TREAT 54 INCLUDE 'mpif.h' 55 !$AGRIF_END_DO_NOT_TREAT 56 #endif 57 58 INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 59 INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 60 INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 61 INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 62 INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 51 63 52 64 !!---------------------------------------------------------------------- … … 56 68 !!---------------------------------------------------------------------- 57 69 CONTAINS 58 59 #else60 !!----------------------------------------------------------------------61 !! Default option shared memory computing62 !!----------------------------------------------------------------------63 !! routines setting the appropriate values64 !! on first and last row and column of the global domain65 !!----------------------------------------------------------------------66 !! lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh67 !! lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh68 !! lbc_lnk : generic interface for lbc_lnk_3d and lbc_lnk_2d69 !! lbc_lnk_3d : set the lateral boundary condition on a 3D variable on ocean mesh70 !! lbc_lnk_2d : set the lateral boundary condition on a 2D variable on ocean mesh71 !! lbc_bdy_lnk : set the lateral BDY boundary condition72 !!----------------------------------------------------------------------73 USE oce ! ocean dynamics and tracers74 USE dom_oce ! ocean space and time domain75 USE in_out_manager ! I/O manager76 USE lbcnfd ! north fold77 78 IMPLICIT NONE79 PRIVATE80 81 INTERFACE lbc_lnk82 MODULE PROCEDURE lbc_lnk_2d , lbc_lnk_3d , lbc_lnk_4d83 END INTERFACE84 INTERFACE lbc_lnk_ptr85 MODULE PROCEDURE lbc_lnk_2d_ptr , lbc_lnk_3d_ptr , lbc_lnk_4d_ptr86 END INTERFACE87 INTERFACE lbc_lnk_multi88 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi89 END INTERFACE90 !91 INTERFACE lbc_bdy_lnk92 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d, lbc_bdy_lnk_4d93 END INTERFACE94 !95 INTERFACE lbc_lnk_icb96 MODULE PROCEDURE lbc_lnk_2d_icb97 END INTERFACE98 99 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions100 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions101 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions102 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions103 104 !!----------------------------------------------------------------------105 !! NEMO/OCE 4.0 , NEMO Consortium (2018)106 !! $Id$107 !! Software governed by the CeCILL license (see ./LICENSE)108 !!----------------------------------------------------------------------109 CONTAINS110 111 !!======================================================================112 !! Default option 3D shared memory computing113 !!======================================================================114 !! routines setting land point, or east-west cyclic,115 !! or north-south cyclic, or north fold values116 !! on first and last row and column of the global domain117 !!----------------------------------------------------------------------118 119 !!----------------------------------------------------------------------120 !! *** routine lbc_lnk_(2,3,4)d ***121 !!122 !! * Argument : dummy argument use in lbc_lnk_... routines123 !! ptab : array or pointer of arrays on which the boundary condition is applied124 !! cd_nat : nature of array grid-points125 !! psgn : sign used across the north fold boundary126 !! kfld : optional, number of pt3d arrays127 !! cd_mpp : optional, fill the overlap area only128 !! pval : optional, background value (used at closed boundaries)129 !!----------------------------------------------------------------------130 !131 ! !== 2D array and array of 2D pointer ==!132 !133 # define DIM_2d134 # define ROUTINE_LNK lbc_lnk_2d135 # include "lbc_lnk_generic.h90"136 # undef ROUTINE_LNK137 # define MULTI138 # define ROUTINE_LNK lbc_lnk_2d_ptr139 # include "lbc_lnk_generic.h90"140 # undef ROUTINE_LNK141 # undef MULTI142 # undef DIM_2d143 !144 ! !== 3D array and array of 3D pointer ==!145 !146 # define DIM_3d147 # define ROUTINE_LNK lbc_lnk_3d148 # include "lbc_lnk_generic.h90"149 # undef ROUTINE_LNK150 # define MULTI151 # define ROUTINE_LNK lbc_lnk_3d_ptr152 # include "lbc_lnk_generic.h90"153 # undef ROUTINE_LNK154 # undef MULTI155 # undef DIM_3d156 !157 ! !== 4D array and array of 4D pointer ==!158 !159 # define DIM_4d160 # define ROUTINE_LNK lbc_lnk_4d161 # include "lbc_lnk_generic.h90"162 # undef ROUTINE_LNK163 # define MULTI164 # define ROUTINE_LNK lbc_lnk_4d_ptr165 # include "lbc_lnk_generic.h90"166 # undef ROUTINE_LNK167 # undef MULTI168 # undef DIM_4d169 170 !!======================================================================171 !! identical routines in both C1D and shared memory computing172 !!======================================================================173 174 !!----------------------------------------------------------------------175 !! *** routine lbc_bdy_lnk_(2,3,4)d ***176 !!177 !! wrapper rountine to 'lbc_lnk_3d'. This wrapper is used178 !! to maintain the same interface with regards to the mpp case179 !!----------------------------------------------------------------------180 181 SUBROUTINE lbc_bdy_lnk_4d( cdname, pt4d, cd_type, psgn, ib_bdy )182 !!----------------------------------------------------------------------183 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine184 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt4d ! 3D array on which the lbc is applied185 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points186 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold187 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set188 !!----------------------------------------------------------------------189 CALL lbc_lnk_4d( cdname, pt4d, cd_type, psgn)190 END SUBROUTINE lbc_bdy_lnk_4d191 192 SUBROUTINE lbc_bdy_lnk_3d( cdname, pt3d, cd_type, psgn, ib_bdy )193 !!----------------------------------------------------------------------194 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine195 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied196 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points197 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold198 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set199 !!----------------------------------------------------------------------200 CALL lbc_lnk_3d( cdname, pt3d, cd_type, psgn)201 END SUBROUTINE lbc_bdy_lnk_3d202 203 204 SUBROUTINE lbc_bdy_lnk_2d( cdname, pt2d, cd_type, psgn, ib_bdy )205 !!----------------------------------------------------------------------206 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine207 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied208 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points209 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold210 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set211 !!----------------------------------------------------------------------212 CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn)213 END SUBROUTINE lbc_bdy_lnk_2d214 215 216 !!gm This routine should be removed with an optional halos size added in argument of generic routines217 218 SUBROUTINE lbc_lnk_2d_icb( cdname, pt2d, cd_type, psgn, ki, kj )219 !!----------------------------------------------------------------------220 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine221 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied222 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points223 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold224 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp)225 !!----------------------------------------------------------------------226 CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn )227 END SUBROUTINE lbc_lnk_2d_icb228 !!gm end229 230 #endif231 232 !!======================================================================233 !! identical routines in both distributed and shared memory computing234 !!======================================================================235 70 236 71 !!---------------------------------------------------------------------- … … 256 91 257 92 # define DIM_2d 93 # define ROUTINE_LOAD load_ptr_2d 258 94 # define ROUTINE_MULTI lbc_lnk_2d_multi 259 # define ROUTINE_LOAD load_ptr_2d260 95 # include "lbc_lnk_multi_generic.h90" 261 96 # undef ROUTINE_MULTI … … 263 98 # undef DIM_2d 264 99 265 266 100 # define DIM_3d 101 # define ROUTINE_LOAD load_ptr_3d 267 102 # define ROUTINE_MULTI lbc_lnk_3d_multi 268 # define ROUTINE_LOAD load_ptr_3d269 103 # include "lbc_lnk_multi_generic.h90" 270 104 # undef ROUTINE_MULTI … … 272 106 # undef DIM_3d 273 107 274 275 108 # define DIM_4d 109 # define ROUTINE_LOAD load_ptr_4d 276 110 # define ROUTINE_MULTI lbc_lnk_4d_multi 277 # define ROUTINE_LOAD load_ptr_4d278 111 # include "lbc_lnk_multi_generic.h90" 279 112 # undef ROUTINE_MULTI … … 281 114 # undef DIM_4d 282 115 116 !!---------------------------------------------------------------------- 117 !! *** routine mpp_lnk_(2,3,4)d *** 118 !! 119 !! * Argument : dummy argument use in mpp_lnk_... routines 120 !! ptab : array or pointer of arrays on which the boundary condition is applied 121 !! cd_nat : nature of array grid-points 122 !! psgn : sign used across the north fold boundary 123 !! kfld : optional, number of pt3d arrays 124 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 125 !! pfillval : optional, background value (used with jpfillcopy) 126 !!---------------------------------------------------------------------- 127 ! 128 ! !== 2D array and array of 2D pointer ==! 129 ! 130 # define DIM_2d 131 # define ROUTINE_LNK mpp_lnk_2d 132 # include "mpp_lnk_generic.h90" 133 # undef ROUTINE_LNK 134 # define MULTI 135 # define ROUTINE_LNK mpp_lnk_2d_ptr 136 # include "mpp_lnk_generic.h90" 137 # undef ROUTINE_LNK 138 # undef MULTI 139 # undef DIM_2d 140 ! 141 ! !== 3D array and array of 3D pointer ==! 142 ! 143 # define DIM_3d 144 # define ROUTINE_LNK mpp_lnk_3d 145 # include "mpp_lnk_generic.h90" 146 # undef ROUTINE_LNK 147 # define MULTI 148 # define ROUTINE_LNK mpp_lnk_3d_ptr 149 # include "mpp_lnk_generic.h90" 150 # undef ROUTINE_LNK 151 # undef MULTI 152 # undef DIM_3d 153 ! 154 ! !== 4D array and array of 4D pointer ==! 155 ! 156 # define DIM_4d 157 # define ROUTINE_LNK mpp_lnk_4d 158 # include "mpp_lnk_generic.h90" 159 # undef ROUTINE_LNK 160 # define MULTI 161 # define ROUTINE_LNK mpp_lnk_4d_ptr 162 # include "mpp_lnk_generic.h90" 163 # undef ROUTINE_LNK 164 # undef MULTI 165 # undef DIM_4d 166 167 !!---------------------------------------------------------------------- 168 !! *** routine mpp_nfd_(2,3,4)d *** 169 !! 170 !! * Argument : dummy argument use in mpp_nfd_... routines 171 !! ptab : array or pointer of arrays on which the boundary condition is applied 172 !! cd_nat : nature of array grid-points 173 !! psgn : sign used across the north fold boundary 174 !! kfld : optional, number of pt3d arrays 175 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 176 !! pfillval : optional, background value (used with jpfillcopy) 177 !!---------------------------------------------------------------------- 178 ! 179 ! !== 2D array and array of 2D pointer ==! 180 ! 181 # define DIM_2d 182 # define ROUTINE_NFD mpp_nfd_2d 183 # include "mpp_nfd_generic.h90" 184 # undef ROUTINE_NFD 185 # define MULTI 186 # define ROUTINE_NFD mpp_nfd_2d_ptr 187 # include "mpp_nfd_generic.h90" 188 # undef ROUTINE_NFD 189 # undef MULTI 190 # undef DIM_2d 191 ! 192 ! !== 3D array and array of 3D pointer ==! 193 ! 194 # define DIM_3d 195 # define ROUTINE_NFD mpp_nfd_3d 196 # include "mpp_nfd_generic.h90" 197 # undef ROUTINE_NFD 198 # define MULTI 199 # define ROUTINE_NFD mpp_nfd_3d_ptr 200 # include "mpp_nfd_generic.h90" 201 # undef ROUTINE_NFD 202 # undef MULTI 203 # undef DIM_3d 204 ! 205 ! !== 4D array and array of 4D pointer ==! 206 ! 207 # define DIM_4d 208 # define ROUTINE_NFD mpp_nfd_4d 209 # include "mpp_nfd_generic.h90" 210 # undef ROUTINE_NFD 211 # define MULTI 212 # define ROUTINE_NFD mpp_nfd_4d_ptr 213 # include "mpp_nfd_generic.h90" 214 # undef ROUTINE_NFD 215 # undef MULTI 216 # undef DIM_4d 217 218 283 219 !!====================================================================== 220 221 222 223 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 224 !!--------------------------------------------------------------------- 225 !! *** routine mpp_lbc_north_icb *** 226 !! 227 !! ** Purpose : Ensure proper north fold horizontal bondary condition 228 !! in mpp configuration in case of jpn1 > 1 and for 2d 229 !! array with outer extra halo 230 !! 231 !! ** Method : North fold condition and mpp with more than one proc 232 !! in i-direction require a specific treatment. We gather 233 !! the 4+kextj northern lines of the global domain on 1 234 !! processor and apply lbc north-fold on this sub array. 235 !! Then we scatter the north fold array back to the processors. 236 !! This routine accounts for an extra halo with icebergs 237 !! and assumes ghost rows and columns have been suppressed. 238 !! 239 !!---------------------------------------------------------------------- 240 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 241 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 242 ! ! = T , U , V , F or W -points 243 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 244 !! ! north fold, = 1. otherwise 245 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold 246 ! 247 INTEGER :: ji, jj, jr 248 INTEGER :: ierr, itaille, ildi, ilei, iilb 249 INTEGER :: ipj, ij, iproc 250 ! 251 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 252 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 253 !!---------------------------------------------------------------------- 254 #if defined key_mpp_mpi 255 ! 256 ipj=4 257 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & 258 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & 259 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) ) 260 ! 261 ztab_e(:,:) = 0._wp 262 znorthloc_e(:,:) = 0._wp 263 ! 264 ij = 1 - kextj 265 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e 266 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 267 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 268 ij = ij + 1 269 END DO 270 ! 271 itaille = jpimax * ( ipj + 2*kextj ) 272 ! 273 IF( ln_timing ) CALL tic_tac(.TRUE.) 274 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, & 275 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, & 276 & ncomm_north, ierr ) 277 ! 278 IF( ln_timing ) CALL tic_tac(.FALSE.) 279 ! 280 DO jr = 1, ndim_rank_north ! recover the global north array 281 iproc = nrank_north(jr) + 1 282 ildi = nldit (iproc) 283 ilei = nleit (iproc) 284 iilb = nimppt(iproc) 285 DO jj = 1-kextj, ipj+kextj 286 DO ji = ildi, ilei 287 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 288 END DO 289 END DO 290 END DO 291 292 ! 2. North-Fold boundary conditions 293 ! ---------------------------------- 294 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 295 296 ij = 1 - kextj 297 !! Scatter back to pt2d 298 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 299 DO ji= 1, jpi 300 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 301 END DO 302 ij = ij +1 303 END DO 304 ! 305 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 306 ! 307 #endif 308 END SUBROUTINE mpp_lbc_north_icb 309 310 311 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 312 !!---------------------------------------------------------------------- 313 !! *** routine mpp_lnk_2d_icb *** 314 !! 315 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) 316 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 317 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 318 !! 319 !! ** Method : Use mppsend and mpprecv function for passing mask 320 !! between processors following neighboring subdomains. 321 !! domain parameters 322 !! jpi : first dimension of the local subdomain 323 !! jpj : second dimension of the local subdomain 324 !! kexti : number of columns for extra outer halo 325 !! kextj : number of rows for extra outer halo 326 !! nbondi : mark for "east-west local boundary" 327 !! nbondj : mark for "north-south local boundary" 328 !! noea : number for local neighboring processors 329 !! nowe : number for local neighboring processors 330 !! noso : number for local neighboring processors 331 !! nono : number for local neighboring processors 332 !!---------------------------------------------------------------------- 333 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 334 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 335 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 336 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 337 INTEGER , INTENT(in ) :: kexti ! extra i-halo width 338 INTEGER , INTENT(in ) :: kextj ! extra j-halo width 339 ! 340 INTEGER :: jl ! dummy loop indices 341 INTEGER :: imigr, iihom, ijhom ! local integers 342 INTEGER :: ipreci, iprecj ! - - 343 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 344 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 345 !! 346 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn 347 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew 348 !!---------------------------------------------------------------------- 349 350 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area 351 iprecj = nn_hls + kextj 352 353 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 354 355 ! 1. standard boundary treatment 356 ! ------------------------------ 357 ! Order matters Here !!!! 358 ! 359 ! ! East-West boundaries 360 ! !* Cyclic east-west 361 IF( l_Iperio ) THEN 362 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east 363 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west 364 ! 365 ELSE !* closed 366 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point 367 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west 368 ENDIF 369 ! ! North-South boundaries 370 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 371 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north 372 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south 373 ELSE !* closed 374 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point 375 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south 376 ENDIF 377 ! 378 379 ! north fold treatment 380 ! ----------------------- 381 IF( npolj /= 0 ) THEN 382 ! 383 SELECT CASE ( jpni ) 384 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 385 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 386 END SELECT 387 ! 388 ENDIF 389 390 ! 2. East and west directions exchange 391 ! ------------------------------------ 392 ! we play with the neigbours AND the row number because of the periodicity 393 ! 394 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 395 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 396 iihom = jpi-nreci-kexti 397 DO jl = 1, ipreci 398 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 399 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 400 END DO 401 END SELECT 402 ! 403 ! ! Migrations 404 imigr = ipreci * ( jpj + 2*kextj ) 405 ! 406 IF( ln_timing ) CALL tic_tac(.TRUE.) 407 ! 408 SELECT CASE ( nbondi ) 409 CASE ( -1 ) 410 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 411 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 412 CALL mpi_wait(ml_req1,ml_stat,ml_err) 413 CASE ( 0 ) 414 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 415 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 416 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 417 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 418 CALL mpi_wait(ml_req1,ml_stat,ml_err) 419 CALL mpi_wait(ml_req2,ml_stat,ml_err) 420 CASE ( 1 ) 421 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 422 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 423 CALL mpi_wait(ml_req1,ml_stat,ml_err) 424 END SELECT 425 ! 426 IF( ln_timing ) CALL tic_tac(.FALSE.) 427 ! 428 ! ! Write Dirichlet lateral conditions 429 iihom = jpi - nn_hls 430 ! 431 SELECT CASE ( nbondi ) 432 CASE ( -1 ) 433 DO jl = 1, ipreci 434 pt2d(iihom+jl,:) = r2dew(:,jl,2) 435 END DO 436 CASE ( 0 ) 437 DO jl = 1, ipreci 438 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 439 pt2d(iihom+jl,:) = r2dew(:,jl,2) 440 END DO 441 CASE ( 1 ) 442 DO jl = 1, ipreci 443 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 444 END DO 445 END SELECT 446 447 448 ! 3. North and south directions 449 ! ----------------------------- 450 ! always closed : we play only with the neigbours 451 ! 452 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 453 ijhom = jpj-nrecj-kextj 454 DO jl = 1, iprecj 455 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 456 r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 457 END DO 458 ENDIF 459 ! 460 ! ! Migrations 461 imigr = iprecj * ( jpi + 2*kexti ) 462 ! 463 IF( ln_timing ) CALL tic_tac(.TRUE.) 464 ! 465 SELECT CASE ( nbondj ) 466 CASE ( -1 ) 467 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 468 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 469 CALL mpi_wait(ml_req1,ml_stat,ml_err) 470 CASE ( 0 ) 471 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 472 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 473 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 474 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 475 CALL mpi_wait(ml_req1,ml_stat,ml_err) 476 CALL mpi_wait(ml_req2,ml_stat,ml_err) 477 CASE ( 1 ) 478 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 479 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 480 CALL mpi_wait(ml_req1,ml_stat,ml_err) 481 END SELECT 482 ! 483 IF( ln_timing ) CALL tic_tac(.FALSE.) 484 ! 485 ! ! Write Dirichlet lateral conditions 486 ijhom = jpj - nn_hls 487 ! 488 SELECT CASE ( nbondj ) 489 CASE ( -1 ) 490 DO jl = 1, iprecj 491 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 492 END DO 493 CASE ( 0 ) 494 DO jl = 1, iprecj 495 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 496 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 497 END DO 498 CASE ( 1 ) 499 DO jl = 1, iprecj 500 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 501 END DO 502 END SELECT 503 ! 504 END SUBROUTINE mpp_lnk_2d_icb 505 284 506 END MODULE lbclnk 285 507 -
NEMO/trunk/src/OCE/LBC/lbcnfd.F90
r10425 r11536 20 20 USE dom_oce ! ocean space and time domain 21 21 USE in_out_manager ! I/O manager 22 USE lib_mpp ! MPP library 22 23 23 24 IMPLICIT NONE -
NEMO/trunk/src/OCE/LBC/lib_mpp.F90
r10982 r11536 32 32 !! ctl_opn : Open file and check if required file is available. 33 33 !! ctl_nam : Prints informations when an error occurs while reading a namelist 34 !! get_unit : give the index of an unused logical unit 35 !!---------------------------------------------------------------------- 36 #if defined key_mpp_mpi 37 !!---------------------------------------------------------------------- 38 !! 'key_mpp_mpi' MPI massively parallel processing library 39 !!---------------------------------------------------------------------- 40 !! lib_mpp_alloc : allocate mpp arrays 41 !! mynode : indentify the processor unit 34 !!---------------------------------------------------------------------- 35 !!---------------------------------------------------------------------- 36 !! mpp_start : get local communicator its size and rank 42 37 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 43 38 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) … … 57 52 !!---------------------------------------------------------------------- 58 53 USE dom_oce ! ocean space and time domain 59 USE lbcnfd ! north fold treatment60 54 USE in_out_manager ! I/O manager 61 55 62 56 IMPLICIT NONE 63 57 PRIVATE 64 65 INTERFACE mpp_nfd66 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d67 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr68 END INTERFACE69 70 ! Interface associated to the mpp_lnk_... routines is defined in lbclnk71 PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d72 PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr73 58 ! 74 !!gm this should be useless 75 PUBLIC mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 76 PUBLIC mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 77 !!gm end 78 ! 79 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 80 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 59 PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam 60 PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free 81 61 PUBLIC mpp_ini_north 82 PUBLIC mpp_lnk_2d_icb83 PUBLIC mpp_lbc_north_icb84 62 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 85 63 PUBLIC mpp_delay_max, mpp_delay_sum, mpp_delay_rcv … … 87 65 PUBLIC mpp_ini_znl 88 66 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 89 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 67 PUBLIC mpp_report 68 PUBLIC tic_tac 69 #if ! defined key_mpp_mpi 70 PUBLIC MPI_Wtime 71 #endif 90 72 91 73 !! * Interfaces … … 113 95 !! MPI variable definition !! 114 96 !! ========================= !! 97 #if defined key_mpp_mpi 115 98 !$AGRIF_DO_NOT_TREAT 116 99 INCLUDE 'mpif.h' 117 100 !$AGRIF_END_DO_NOT_TREAT 118 119 101 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 102 #else 103 INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 104 INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 105 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 106 #endif 120 107 121 108 INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2) … … 145 132 INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm 146 133 INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north 147 148 ! Type of send : standard, buffered, immediate149 CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend)150 LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I')151 INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend152 134 153 135 ! Communications summary report … … 187 169 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 188 170 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 189 171 190 172 !!---------------------------------------------------------------------- 191 173 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 195 177 CONTAINS 196 178 197 FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 198 !!---------------------------------------------------------------------- 199 !! *** routine mynode *** 200 !! 201 !! ** Purpose : Find processor unit 202 !!---------------------------------------------------------------------- 203 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! 204 CHARACTER(len=*) , INTENT(in ) :: ldname ! 205 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 206 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 207 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 208 INTEGER , INTENT(inout) :: kstop ! stop indicator 179 SUBROUTINE mpp_start( localComm ) 180 !!---------------------------------------------------------------------- 181 !! *** routine mpp_start *** 182 !! 183 !! ** Purpose : get mpi_comm_oce, mpprank and mppsize 184 !!---------------------------------------------------------------------- 209 185 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 210 186 ! 211 INTEGER :: mynode, ierr, code, ji, ii, ios 212 LOGICAL :: mpi_was_called 213 ! 214 NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 215 !!---------------------------------------------------------------------- 216 ! 217 ii = 1 218 WRITE(ldtxt(ii),*) ; ii = ii + 1 219 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 220 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 221 ! 222 REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables 223 READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 224 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 225 ! 226 REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables 227 READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 228 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 229 ! 230 ! ! control print 231 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 232 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 233 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 234 ! 235 IF( jpni < 1 .OR. jpnj < 1 ) THEN 236 WRITE(ldtxt(ii),*) ' jpni and jpnj will be calculated automatically' ; ii = ii + 1 237 ELSE 238 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 239 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 240 ENDIF 241 242 WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 243 244 CALL mpi_initialized ( mpi_was_called, code ) 245 IF( code /= MPI_SUCCESS ) THEN 246 DO ji = 1, SIZE(ldtxt) 247 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 248 END DO 249 WRITE(*, cform_err) 250 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 251 CALL mpi_abort( mpi_comm_world, code, ierr ) 252 ENDIF 253 254 IF( mpi_was_called ) THEN 255 ! 256 SELECT CASE ( cn_mpi_send ) 257 CASE ( 'S' ) ! Standard mpi send (blocking) 258 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 259 CASE ( 'B' ) ! Buffer mpi send (blocking) 260 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 261 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 262 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 263 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 264 l_isend = .TRUE. 265 CASE DEFAULT 266 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 267 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 268 kstop = kstop + 1 269 END SELECT 270 ! 271 ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 272 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 273 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 274 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 275 kstop = kstop + 1 276 ELSE 277 SELECT CASE ( cn_mpi_send ) 278 CASE ( 'S' ) ! Standard mpi send (blocking) 279 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 280 CALL mpi_init( ierr ) 281 CASE ( 'B' ) ! Buffer mpi send (blocking) 282 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 283 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 284 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 285 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 286 l_isend = .TRUE. 287 CALL mpi_init( ierr ) 288 CASE DEFAULT 289 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 290 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 291 kstop = kstop + 1 292 END SELECT 293 ! 294 ENDIF 295 187 INTEGER :: ierr 188 LOGICAL :: llmpi_init 189 !!---------------------------------------------------------------------- 190 #if defined key_mpp_mpi 191 ! 192 CALL mpi_initialized ( llmpi_init, ierr ) 193 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 194 195 IF( .NOT. llmpi_init ) THEN 196 IF( PRESENT(localComm) ) THEN 197 WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 198 WRITE(ctmp2,*) ' without calling MPI_Init before ! ' 199 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 200 ENDIF 201 CALL mpi_init( ierr ) 202 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 203 ENDIF 204 296 205 IF( PRESENT(localComm) ) THEN 297 206 IF( Agrif_Root() ) THEN … … 299 208 ENDIF 300 209 ELSE 301 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 302 IF( code /= MPI_SUCCESS ) THEN 303 DO ji = 1, SIZE(ldtxt) 304 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 305 END DO 306 WRITE(*, cform_err) 307 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 308 CALL mpi_abort( mpi_comm_world, code, ierr ) 309 ENDIF 310 ENDIF 311 312 #if defined key_agrif 210 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 211 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 212 ENDIF 213 214 # if defined key_agrif 313 215 IF( Agrif_Root() ) THEN 314 216 CALL Agrif_MPI_Init(mpi_comm_oce) … … 316 218 CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 317 219 ENDIF 318 # endif220 # endif 319 221 320 222 CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 321 223 CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 322 mynode = mpprank323 324 IF( mynode == 0 ) THEN325 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )326 WRITE(kumond, nammpp)327 ENDIF328 224 ! 329 225 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 330 226 ! 331 END FUNCTION mynode 332 333 !!---------------------------------------------------------------------- 334 !! *** routine mpp_lnk_(2,3,4)d *** 335 !! 336 !! * Argument : dummy argument use in mpp_lnk_... routines 337 !! ptab : array or pointer of arrays on which the boundary condition is applied 338 !! cd_nat : nature of array grid-points 339 !! psgn : sign used across the north fold boundary 340 !! kfld : optional, number of pt3d arrays 341 !! cd_mpp : optional, fill the overlap area only 342 !! pval : optional, background value (used at closed boundaries) 343 !!---------------------------------------------------------------------- 344 ! 345 ! !== 2D array and array of 2D pointer ==! 346 ! 347 # define DIM_2d 348 # define ROUTINE_LNK mpp_lnk_2d 349 # include "mpp_lnk_generic.h90" 350 # undef ROUTINE_LNK 351 # define MULTI 352 # define ROUTINE_LNK mpp_lnk_2d_ptr 353 # include "mpp_lnk_generic.h90" 354 # undef ROUTINE_LNK 355 # undef MULTI 356 # undef DIM_2d 357 ! 358 ! !== 3D array and array of 3D pointer ==! 359 ! 360 # define DIM_3d 361 # define ROUTINE_LNK mpp_lnk_3d 362 # include "mpp_lnk_generic.h90" 363 # undef ROUTINE_LNK 364 # define MULTI 365 # define ROUTINE_LNK mpp_lnk_3d_ptr 366 # include "mpp_lnk_generic.h90" 367 # undef ROUTINE_LNK 368 # undef MULTI 369 # undef DIM_3d 370 ! 371 ! !== 4D array and array of 4D pointer ==! 372 ! 373 # define DIM_4d 374 # define ROUTINE_LNK mpp_lnk_4d 375 # include "mpp_lnk_generic.h90" 376 # undef ROUTINE_LNK 377 # define MULTI 378 # define ROUTINE_LNK mpp_lnk_4d_ptr 379 # include "mpp_lnk_generic.h90" 380 # undef ROUTINE_LNK 381 # undef MULTI 382 # undef DIM_4d 383 384 !!---------------------------------------------------------------------- 385 !! *** routine mpp_nfd_(2,3,4)d *** 386 !! 387 !! * Argument : dummy argument use in mpp_nfd_... routines 388 !! ptab : array or pointer of arrays on which the boundary condition is applied 389 !! cd_nat : nature of array grid-points 390 !! psgn : sign used across the north fold boundary 391 !! kfld : optional, number of pt3d arrays 392 !! cd_mpp : optional, fill the overlap area only 393 !! pval : optional, background value (used at closed boundaries) 394 !!---------------------------------------------------------------------- 395 ! 396 ! !== 2D array and array of 2D pointer ==! 397 ! 398 # define DIM_2d 399 # define ROUTINE_NFD mpp_nfd_2d 400 # include "mpp_nfd_generic.h90" 401 # undef ROUTINE_NFD 402 # define MULTI 403 # define ROUTINE_NFD mpp_nfd_2d_ptr 404 # include "mpp_nfd_generic.h90" 405 # undef ROUTINE_NFD 406 # undef MULTI 407 # undef DIM_2d 408 ! 409 ! !== 3D array and array of 3D pointer ==! 410 ! 411 # define DIM_3d 412 # define ROUTINE_NFD mpp_nfd_3d 413 # include "mpp_nfd_generic.h90" 414 # undef ROUTINE_NFD 415 # define MULTI 416 # define ROUTINE_NFD mpp_nfd_3d_ptr 417 # include "mpp_nfd_generic.h90" 418 # undef ROUTINE_NFD 419 # undef MULTI 420 # undef DIM_3d 421 ! 422 ! !== 4D array and array of 4D pointer ==! 423 ! 424 # define DIM_4d 425 # define ROUTINE_NFD mpp_nfd_4d 426 # include "mpp_nfd_generic.h90" 427 # undef ROUTINE_NFD 428 # define MULTI 429 # define ROUTINE_NFD mpp_nfd_4d_ptr 430 # include "mpp_nfd_generic.h90" 431 # undef ROUTINE_NFD 432 # undef MULTI 433 # undef DIM_4d 434 435 436 !!---------------------------------------------------------------------- 437 !! *** routine mpp_lnk_bdy_(2,3,4)d *** 438 !! 439 !! * Argument : dummy argument use in mpp_lnk_... routines 440 !! ptab : array or pointer of arrays on which the boundary condition is applied 441 !! cd_nat : nature of array grid-points 442 !! psgn : sign used across the north fold boundary 443 !! kb_bdy : BDY boundary set 444 !! kfld : optional, number of pt3d arrays 445 !!---------------------------------------------------------------------- 446 ! 447 ! !== 2D array and array of 2D pointer ==! 448 ! 449 # define DIM_2d 450 # define ROUTINE_BDY mpp_lnk_bdy_2d 451 # include "mpp_bdy_generic.h90" 452 # undef ROUTINE_BDY 453 # undef DIM_2d 454 ! 455 ! !== 3D array and array of 3D pointer ==! 456 ! 457 # define DIM_3d 458 # define ROUTINE_BDY mpp_lnk_bdy_3d 459 # include "mpp_bdy_generic.h90" 460 # undef ROUTINE_BDY 461 # undef DIM_3d 462 ! 463 ! !== 4D array and array of 4D pointer ==! 464 ! 465 # define DIM_4d 466 # define ROUTINE_BDY mpp_lnk_bdy_4d 467 # include "mpp_bdy_generic.h90" 468 # undef ROUTINE_BDY 469 # undef DIM_4d 470 471 !!---------------------------------------------------------------------- 472 !! 473 !! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D 474 475 476 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 477 478 479 !!---------------------------------------------------------------------- 480 227 #else 228 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 229 mppsize = 1 230 mpprank = 0 231 #endif 232 END SUBROUTINE mpp_start 481 233 482 234 … … 497 249 !!---------------------------------------------------------------------- 498 250 ! 499 SELECT CASE ( cn_mpi_send ) 500 CASE ( 'S' ) ! Standard mpi send (blocking) 501 CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag ) 502 CASE ( 'B' ) ! Buffer mpi send (blocking) 503 CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag ) 504 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 505 ! be carefull, one more argument here : the mpi request identifier.. 506 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 507 END SELECT 251 #if defined key_mpp_mpi 252 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 253 #endif 508 254 ! 509 255 END SUBROUTINE mppsend … … 527 273 !!---------------------------------------------------------------------- 528 274 ! 275 #if defined key_mpp_mpi 529 276 ! If a specific process number has been passed to the receive call, 530 277 ! use that one. Default is to use mpi_any_source … … 533 280 ! 534 281 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 282 #endif 535 283 ! 536 284 END SUBROUTINE mpprecv … … 553 301 ! 554 302 itaille = jpi * jpj 303 #if defined key_mpp_mpi 555 304 CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & 556 305 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 306 #else 307 pio(:,:,1) = ptab(:,:) 308 #endif 557 309 ! 558 310 END SUBROUTINE mppgather … … 576 328 itaille = jpi * jpj 577 329 ! 330 #if defined key_mpp_mpi 578 331 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & 579 332 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 333 #else 334 ptab(:,:) = pio(:,:,1) 335 #endif 580 336 ! 581 337 END SUBROUTINE mppscatter … … 601 357 COMPLEX(wp), ALLOCATABLE, DIMENSION(:) :: ytmp 602 358 !!---------------------------------------------------------------------- 359 #if defined key_mpp_mpi 603 360 ilocalcomm = mpi_comm_oce 604 361 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 639 396 640 397 ! send y_in into todelay(idvar)%y1d with a non-blocking communication 641 # if defined key_mpi2398 # if defined key_mpi2 642 399 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 643 400 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 644 401 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 402 # else 403 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 404 # endif 645 405 #else 646 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr)406 pout(:) = REAL(y_in(:), wp) 647 407 #endif 648 408 … … 668 428 INTEGER :: ierr, ilocalcomm 669 429 !!---------------------------------------------------------------------- 430 #if defined key_mpp_mpi 670 431 ilocalcomm = mpi_comm_oce 671 432 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 702 463 703 464 ! send p_in into todelay(idvar)%z1d with a non-blocking communication 704 # if defined key_mpi2465 # if defined key_mpi2 705 466 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 706 467 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 707 468 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 469 # else 470 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 471 # endif 708 472 #else 709 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr)473 pout(:) = p_in(:) 710 474 #endif 711 475 … … 723 487 INTEGER :: ierr 724 488 !!---------------------------------------------------------------------- 489 #if defined key_mpp_mpi 725 490 IF( ndelayid(kid) /= -2 ) THEN 726 491 #if ! defined key_mpi2 … … 732 497 ndelayid(kid) = -2 ! add flag to know that mpi_wait was already called on kid 733 498 ENDIF 499 #endif 734 500 END SUBROUTINE mpp_delay_rcv 735 501 … … 890 656 !!----------------------------------------------------------------------- 891 657 ! 658 #if defined key_mpp_mpi 892 659 CALL mpi_barrier( mpi_comm_oce, ierror ) 660 #endif 893 661 ! 894 662 END SUBROUTINE mppsync 895 663 896 664 897 SUBROUTINE mppstop( ld final, ld_force_abort )665 SUBROUTINE mppstop( ld_abort ) 898 666 !!---------------------------------------------------------------------- 899 667 !! *** routine mppstop *** … … 902 670 !! 903 671 !!---------------------------------------------------------------------- 904 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 905 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 906 LOGICAL :: llfinal, ll_force_abort 672 LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number 673 LOGICAL :: ll_abort 907 674 INTEGER :: info 908 675 !!---------------------------------------------------------------------- 909 llfinal = .FALSE. 910 IF( PRESENT(ldfinal) ) llfinal = ldfinal 911 ll_force_abort = .FALSE. 912 IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 913 ! 914 IF(ll_force_abort) THEN 676 ll_abort = .FALSE. 677 IF( PRESENT(ld_abort) ) ll_abort = ld_abort 678 ! 679 #if defined key_mpp_mpi 680 IF(ll_abort) THEN 915 681 CALL mpi_abort( MPI_COMM_WORLD ) 916 682 ELSE … … 918 684 CALL mpi_finalize( info ) 919 685 ENDIF 920 IF( .NOT. llfinal ) STOP 123 686 #endif 687 IF( ll_abort ) STOP 123 921 688 ! 922 689 END SUBROUTINE mppstop … … 930 697 !!---------------------------------------------------------------------- 931 698 ! 699 #if defined key_mpp_mpi 932 700 CALL MPI_COMM_FREE(kcom, ierr) 701 #endif 933 702 ! 934 703 END SUBROUTINE mpp_comm_free … … 960 729 INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork 961 730 !!---------------------------------------------------------------------- 731 #if defined key_mpp_mpi 962 732 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world 963 733 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world … … 965 735 ! 966 736 ALLOCATE( kwork(jpnij), STAT=ierr ) 967 IF( ierr /= 0 ) THEN 968 WRITE(kumout, cform_err) 969 WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 970 CALL mppstop 971 ENDIF 737 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 972 738 973 739 IF( jpnj == 1 ) THEN … … 1031 797 1032 798 DEALLOCATE(kwork) 799 #endif 1033 800 1034 801 END SUBROUTINE mpp_ini_znl … … 1062 829 !!---------------------------------------------------------------------- 1063 830 ! 831 #if defined key_mpp_mpi 1064 832 njmppmax = MAXVAL( njmppt ) 1065 833 ! … … 1093 861 CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 1094 862 ! 863 #endif 1095 864 END SUBROUTINE mpp_ini_north 1096 1097 1098 SUBROUTINE mpi_init_oce( ldtxt, ksft, code )1099 !!---------------------------------------------------------------------1100 !! *** routine mpp_init.opa ***1101 !!1102 !! ** Purpose :: export and attach a MPI buffer for bsend1103 !!1104 !! ** Method :: define buffer size in namelist, if 0 no buffer attachment1105 !! but classical mpi_init1106 !!1107 !! History :: 01/11 :: IDRIS initial version for IBM only1108 !! 08/04 :: R. Benshila, generalisation1109 !!---------------------------------------------------------------------1110 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt1111 INTEGER , INTENT(inout) :: ksft1112 INTEGER , INTENT( out) :: code1113 INTEGER :: ierr, ji1114 LOGICAL :: mpi_was_called1115 !!---------------------------------------------------------------------1116 !1117 CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization1118 IF ( code /= MPI_SUCCESS ) THEN1119 DO ji = 1, SIZE(ldtxt)1120 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1121 END DO1122 WRITE(*, cform_err)1123 WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'1124 CALL mpi_abort( mpi_comm_world, code, ierr )1125 ENDIF1126 !1127 IF( .NOT. mpi_was_called ) THEN1128 CALL mpi_init( code )1129 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code )1130 IF ( code /= MPI_SUCCESS ) THEN1131 DO ji = 1, SIZE(ldtxt)1132 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1133 END DO1134 WRITE(*, cform_err)1135 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'1136 CALL mpi_abort( mpi_comm_world, code, ierr )1137 ENDIF1138 ENDIF1139 !1140 IF( nn_buffer > 0 ) THEN1141 WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 11142 ! Buffer allocation and attachment1143 ALLOCATE( tampon(nn_buffer), stat = ierr )1144 IF( ierr /= 0 ) THEN1145 DO ji = 1, SIZE(ldtxt)1146 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1147 END DO1148 WRITE(*, cform_err)1149 WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr1150 CALL mpi_abort( mpi_comm_world, code, ierr )1151 END IF1152 CALL mpi_buffer_attach( tampon, nn_buffer, code )1153 ENDIF1154 !1155 END SUBROUTINE mpi_init_oce1156 865 1157 866 … … 1187 896 1188 897 1189 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)1190 !!---------------------------------------------------------------------1191 !! *** routine mpp_lbc_north_icb ***1192 !!1193 !! ** Purpose : Ensure proper north fold horizontal bondary condition1194 !! in mpp configuration in case of jpn1 > 1 and for 2d1195 !! array with outer extra halo1196 !!1197 !! ** Method : North fold condition and mpp with more than one proc1198 !! in i-direction require a specific treatment. We gather1199 !! the 4+kextj northern lines of the global domain on 11200 !! processor and apply lbc north-fold on this sub array.1201 !! Then we scatter the north fold array back to the processors.1202 !! This routine accounts for an extra halo with icebergs1203 !! and assumes ghost rows and columns have been suppressed.1204 !!1205 !!----------------------------------------------------------------------1206 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo1207 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points1208 ! ! = T , U , V , F or W -points1209 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the1210 !! ! north fold, = 1. otherwise1211 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold1212 !1213 INTEGER :: ji, jj, jr1214 INTEGER :: ierr, itaille, ildi, ilei, iilb1215 INTEGER :: ipj, ij, iproc1216 !1217 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e1218 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e1219 !!----------------------------------------------------------------------1220 !1221 ipj=41222 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , &1223 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , &1224 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) )1225 !1226 ztab_e(:,:) = 0._wp1227 znorthloc_e(:,:) = 0._wp1228 !1229 ij = 1 - kextj1230 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e1231 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1232 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)1233 ij = ij + 11234 END DO1235 !1236 itaille = jpimax * ( ipj + 2*kextj )1237 !1238 IF( ln_timing ) CALL tic_tac(.TRUE.)1239 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, &1240 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, &1241 & ncomm_north, ierr )1242 !1243 IF( ln_timing ) CALL tic_tac(.FALSE.)1244 !1245 DO jr = 1, ndim_rank_north ! recover the global north array1246 iproc = nrank_north(jr) + 11247 ildi = nldit (iproc)1248 ilei = nleit (iproc)1249 iilb = nimppt(iproc)1250 DO jj = 1-kextj, ipj+kextj1251 DO ji = ildi, ilei1252 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)1253 END DO1254 END DO1255 END DO1256 1257 ! 2. North-Fold boundary conditions1258 ! ----------------------------------1259 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )1260 1261 ij = 1 - kextj1262 !! Scatter back to pt2d1263 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1264 DO ji= 1, jpi1265 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)1266 END DO1267 ij = ij +11268 END DO1269 !1270 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )1271 !1272 END SUBROUTINE mpp_lbc_north_icb1273 1274 1275 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj )1276 !!----------------------------------------------------------------------1277 !! *** routine mpp_lnk_2d_icb ***1278 !!1279 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs)1280 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)1281 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.1282 !!1283 !! ** Method : Use mppsend and mpprecv function for passing mask1284 !! between processors following neighboring subdomains.1285 !! domain parameters1286 !! jpi : first dimension of the local subdomain1287 !! jpj : second dimension of the local subdomain1288 !! kexti : number of columns for extra outer halo1289 !! kextj : number of rows for extra outer halo1290 !! nbondi : mark for "east-west local boundary"1291 !! nbondj : mark for "north-south local boundary"1292 !! noea : number for local neighboring processors1293 !! nowe : number for local neighboring processors1294 !! noso : number for local neighboring processors1295 !! nono : number for local neighboring processors1296 !!----------------------------------------------------------------------1297 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine1298 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo1299 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1300 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1301 INTEGER , INTENT(in ) :: kexti ! extra i-halo width1302 INTEGER , INTENT(in ) :: kextj ! extra j-halo width1303 !1304 INTEGER :: jl ! dummy loop indices1305 INTEGER :: imigr, iihom, ijhom ! local integers1306 INTEGER :: ipreci, iprecj ! - -1307 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1308 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1309 !!1310 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn1311 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew1312 !!----------------------------------------------------------------------1313 1314 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area1315 iprecj = nn_hls + kextj1316 1317 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )1318 1319 ! 1. standard boundary treatment1320 ! ------------------------------1321 ! Order matters Here !!!!1322 !1323 ! ! East-West boundaries1324 ! !* Cyclic east-west1325 IF( l_Iperio ) THEN1326 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east1327 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west1328 !1329 ELSE !* closed1330 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point1331 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west1332 ENDIF1333 ! ! North-South boundaries1334 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)1335 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north1336 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south1337 ELSE !* closed1338 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point1339 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south1340 ENDIF1341 !1342 1343 ! north fold treatment1344 ! -----------------------1345 IF( npolj /= 0 ) THEN1346 !1347 SELECT CASE ( jpni )1348 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1349 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1350 END SELECT1351 !1352 ENDIF1353 1354 ! 2. East and west directions exchange1355 ! ------------------------------------1356 ! we play with the neigbours AND the row number because of the periodicity1357 !1358 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions1359 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1360 iihom = jpi-nreci-kexti1361 DO jl = 1, ipreci1362 r2dew(:,jl,1) = pt2d(nn_hls+jl,:)1363 r2dwe(:,jl,1) = pt2d(iihom +jl,:)1364 END DO1365 END SELECT1366 !1367 ! ! Migrations1368 imigr = ipreci * ( jpj + 2*kextj )1369 !1370 IF( ln_timing ) CALL tic_tac(.TRUE.)1371 !1372 SELECT CASE ( nbondi )1373 CASE ( -1 )1374 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )1375 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1376 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1377 CASE ( 0 )1378 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1379 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )1380 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1381 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1382 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1383 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1384 CASE ( 1 )1385 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1386 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1387 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1388 END SELECT1389 !1390 IF( ln_timing ) CALL tic_tac(.FALSE.)1391 !1392 ! ! Write Dirichlet lateral conditions1393 iihom = jpi - nn_hls1394 !1395 SELECT CASE ( nbondi )1396 CASE ( -1 )1397 DO jl = 1, ipreci1398 pt2d(iihom+jl,:) = r2dew(:,jl,2)1399 END DO1400 CASE ( 0 )1401 DO jl = 1, ipreci1402 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1403 pt2d(iihom+jl,:) = r2dew(:,jl,2)1404 END DO1405 CASE ( 1 )1406 DO jl = 1, ipreci1407 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1408 END DO1409 END SELECT1410 1411 1412 ! 3. North and south directions1413 ! -----------------------------1414 ! always closed : we play only with the neigbours1415 !1416 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions1417 ijhom = jpj-nrecj-kextj1418 DO jl = 1, iprecj1419 r2dsn(:,jl,1) = pt2d(:,ijhom +jl)1420 r2dns(:,jl,1) = pt2d(:,nn_hls+jl)1421 END DO1422 ENDIF1423 !1424 ! ! Migrations1425 imigr = iprecj * ( jpi + 2*kexti )1426 !1427 IF( ln_timing ) CALL tic_tac(.TRUE.)1428 !1429 SELECT CASE ( nbondj )1430 CASE ( -1 )1431 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )1432 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1433 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1434 CASE ( 0 )1435 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1436 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )1437 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1438 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1439 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1440 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1441 CASE ( 1 )1442 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1443 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1444 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1445 END SELECT1446 !1447 IF( ln_timing ) CALL tic_tac(.FALSE.)1448 !1449 ! ! Write Dirichlet lateral conditions1450 ijhom = jpj - nn_hls1451 !1452 SELECT CASE ( nbondj )1453 CASE ( -1 )1454 DO jl = 1, iprecj1455 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1456 END DO1457 CASE ( 0 )1458 DO jl = 1, iprecj1459 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1460 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1461 END DO1462 CASE ( 1 )1463 DO jl = 1, iprecj1464 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1465 END DO1466 END SELECT1467 !1468 END SUBROUTINE mpp_lnk_2d_icb1469 1470 1471 898 SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 1472 899 !!---------------------------------------------------------------------- … … 1484 911 INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices 1485 912 !!---------------------------------------------------------------------- 913 #if defined key_mpp_mpi 1486 914 ! 1487 915 ll_lbc = .FALSE. … … 1594 1022 DEALLOCATE(crname_lbc) 1595 1023 ENDIF 1024 #endif 1596 1025 END SUBROUTINE mpp_report 1597 1026 … … 1604 1033 REAL(wp), SAVE :: tic_ct = 0._wp 1605 1034 INTEGER :: ii 1035 #if defined key_mpp_mpi 1606 1036 1607 1037 IF( ncom_stp <= nit000 ) RETURN … … 1619 1049 tic_ct = MPI_Wtime() ! start count tac->tic (waiting time) 1620 1050 ENDIF 1051 #endif 1621 1052 1622 1053 END SUBROUTINE tic_tac 1623 1054 1055 #if ! defined key_mpp_mpi 1056 SUBROUTINE mpi_wait(request, status, ierror) 1057 INTEGER , INTENT(in ) :: request 1058 INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status 1059 INTEGER , INTENT( out) :: ierror 1060 END SUBROUTINE mpi_wait 1061 1624 1062 1625 #else 1626 !!---------------------------------------------------------------------- 1627 !! Default case: Dummy module share memory computing 1628 !!---------------------------------------------------------------------- 1629 USE in_out_manager 1630 1631 INTERFACE mpp_sum 1632 MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 1633 END INTERFACE 1634 INTERFACE mpp_max 1635 MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 1636 END INTERFACE 1637 INTERFACE mpp_min 1638 MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 1639 END INTERFACE 1640 INTERFACE mpp_minloc 1641 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 1642 END INTERFACE 1643 INTERFACE mpp_maxloc 1644 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 1645 END INTERFACE 1646 1647 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 1648 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 1649 INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator 1650 1651 INTEGER, PARAMETER, PUBLIC :: nbdelay = 0 ! make sure we don't enter loops: DO ji = 1, nbdelay 1652 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaylist = 'empty' 1653 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaycpnt = 'empty' 1654 LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. 1655 TYPE :: DELAYARR 1656 REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() 1657 COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL() 1658 END TYPE DELAYARR 1659 TYPE( DELAYARR ), DIMENSION(1), PUBLIC :: todelay 1660 INTEGER, PUBLIC, DIMENSION(1) :: ndelayid = -1 1661 !!---------------------------------------------------------------------- 1662 CONTAINS 1663 1664 INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function 1665 INTEGER, INTENT(in) :: kumout 1666 lib_mpp_alloc = 0 1667 END FUNCTION lib_mpp_alloc 1668 1669 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 1670 INTEGER, OPTIONAL , INTENT(in ) :: localComm 1671 CHARACTER(len=*),DIMENSION(:) :: ldtxt 1672 CHARACTER(len=*) :: ldname 1673 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 1674 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 1675 function_value = 0 1676 IF( .FALSE. ) ldtxt(:) = 'never done' 1677 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 1678 END FUNCTION mynode 1679 1680 SUBROUTINE mppsync ! Dummy routine 1681 END SUBROUTINE mppsync 1682 1683 !!---------------------------------------------------------------------- 1684 !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** 1685 !! 1686 !!---------------------------------------------------------------------- 1687 !! 1688 # define OPERATION_MAX 1689 # define INTEGER_TYPE 1690 # define DIM_0d 1691 # define ROUTINE_ALLREDUCE mppmax_int 1692 # include "mpp_allreduce_generic.h90" 1693 # undef ROUTINE_ALLREDUCE 1694 # undef DIM_0d 1695 # define DIM_1d 1696 # define ROUTINE_ALLREDUCE mppmax_a_int 1697 # include "mpp_allreduce_generic.h90" 1698 # undef ROUTINE_ALLREDUCE 1699 # undef DIM_1d 1700 # undef INTEGER_TYPE 1701 ! 1702 # define REAL_TYPE 1703 # define DIM_0d 1704 # define ROUTINE_ALLREDUCE mppmax_real 1705 # include "mpp_allreduce_generic.h90" 1706 # undef ROUTINE_ALLREDUCE 1707 # undef DIM_0d 1708 # define DIM_1d 1709 # define ROUTINE_ALLREDUCE mppmax_a_real 1710 # include "mpp_allreduce_generic.h90" 1711 # undef ROUTINE_ALLREDUCE 1712 # undef DIM_1d 1713 # undef REAL_TYPE 1714 # undef OPERATION_MAX 1715 !!---------------------------------------------------------------------- 1716 !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** 1717 !! 1718 !!---------------------------------------------------------------------- 1719 !! 1720 # define OPERATION_MIN 1721 # define INTEGER_TYPE 1722 # define DIM_0d 1723 # define ROUTINE_ALLREDUCE mppmin_int 1724 # include "mpp_allreduce_generic.h90" 1725 # undef ROUTINE_ALLREDUCE 1726 # undef DIM_0d 1727 # define DIM_1d 1728 # define ROUTINE_ALLREDUCE mppmin_a_int 1729 # include "mpp_allreduce_generic.h90" 1730 # undef ROUTINE_ALLREDUCE 1731 # undef DIM_1d 1732 # undef INTEGER_TYPE 1733 ! 1734 # define REAL_TYPE 1735 # define DIM_0d 1736 # define ROUTINE_ALLREDUCE mppmin_real 1737 # include "mpp_allreduce_generic.h90" 1738 # undef ROUTINE_ALLREDUCE 1739 # undef DIM_0d 1740 # define DIM_1d 1741 # define ROUTINE_ALLREDUCE mppmin_a_real 1742 # include "mpp_allreduce_generic.h90" 1743 # undef ROUTINE_ALLREDUCE 1744 # undef DIM_1d 1745 # undef REAL_TYPE 1746 # undef OPERATION_MIN 1747 1748 !!---------------------------------------------------------------------- 1749 !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** 1750 !! 1751 !! Global sum of 1D array or a variable (integer, real or complex) 1752 !!---------------------------------------------------------------------- 1753 !! 1754 # define OPERATION_SUM 1755 # define INTEGER_TYPE 1756 # define DIM_0d 1757 # define ROUTINE_ALLREDUCE mppsum_int 1758 # include "mpp_allreduce_generic.h90" 1759 # undef ROUTINE_ALLREDUCE 1760 # undef DIM_0d 1761 # define DIM_1d 1762 # define ROUTINE_ALLREDUCE mppsum_a_int 1763 # include "mpp_allreduce_generic.h90" 1764 # undef ROUTINE_ALLREDUCE 1765 # undef DIM_1d 1766 # undef INTEGER_TYPE 1767 ! 1768 # define REAL_TYPE 1769 # define DIM_0d 1770 # define ROUTINE_ALLREDUCE mppsum_real 1771 # include "mpp_allreduce_generic.h90" 1772 # undef ROUTINE_ALLREDUCE 1773 # undef DIM_0d 1774 # define DIM_1d 1775 # define ROUTINE_ALLREDUCE mppsum_a_real 1776 # include "mpp_allreduce_generic.h90" 1777 # undef ROUTINE_ALLREDUCE 1778 # undef DIM_1d 1779 # undef REAL_TYPE 1780 # undef OPERATION_SUM 1781 1782 # define OPERATION_SUM_DD 1783 # define COMPLEX_TYPE 1784 # define DIM_0d 1785 # define ROUTINE_ALLREDUCE mppsum_realdd 1786 # include "mpp_allreduce_generic.h90" 1787 # undef ROUTINE_ALLREDUCE 1788 # undef DIM_0d 1789 # define DIM_1d 1790 # define ROUTINE_ALLREDUCE mppsum_a_realdd 1791 # include "mpp_allreduce_generic.h90" 1792 # undef ROUTINE_ALLREDUCE 1793 # undef DIM_1d 1794 # undef COMPLEX_TYPE 1795 # undef OPERATION_SUM_DD 1796 1797 !!---------------------------------------------------------------------- 1798 !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 1799 !! 1800 !!---------------------------------------------------------------------- 1801 !! 1802 # define OPERATION_MINLOC 1803 # define DIM_2d 1804 # define ROUTINE_LOC mpp_minloc2d 1805 # include "mpp_loc_generic.h90" 1806 # undef ROUTINE_LOC 1807 # undef DIM_2d 1808 # define DIM_3d 1809 # define ROUTINE_LOC mpp_minloc3d 1810 # include "mpp_loc_generic.h90" 1811 # undef ROUTINE_LOC 1812 # undef DIM_3d 1813 # undef OPERATION_MINLOC 1814 1815 # define OPERATION_MAXLOC 1816 # define DIM_2d 1817 # define ROUTINE_LOC mpp_maxloc2d 1818 # include "mpp_loc_generic.h90" 1819 # undef ROUTINE_LOC 1820 # undef DIM_2d 1821 # define DIM_3d 1822 # define ROUTINE_LOC mpp_maxloc3d 1823 # include "mpp_loc_generic.h90" 1824 # undef ROUTINE_LOC 1825 # undef DIM_3d 1826 # undef OPERATION_MAXLOC 1827 1828 SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) 1829 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1830 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1831 COMPLEX(wp), INTENT(in ), DIMENSION(:) :: y_in 1832 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1833 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1834 INTEGER, INTENT(in ), OPTIONAL :: kcom 1835 ! 1836 pout(:) = REAL(y_in(:), wp) 1837 END SUBROUTINE mpp_delay_sum 1838 1839 SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 1840 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1841 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1842 REAL(wp), INTENT(in ), DIMENSION(:) :: p_in 1843 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1844 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1845 INTEGER, INTENT(in ), OPTIONAL :: kcom 1846 ! 1847 pout(:) = p_in(:) 1848 END SUBROUTINE mpp_delay_max 1849 1850 SUBROUTINE mpp_delay_rcv( kid ) 1851 INTEGER,INTENT(in ) :: kid 1852 WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 1853 END SUBROUTINE mpp_delay_rcv 1854 1855 SUBROUTINE mppstop( ldfinal, ld_force_abort ) 1856 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 1857 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 1858 STOP ! non MPP case, just stop the run 1859 END SUBROUTINE mppstop 1860 1861 SUBROUTINE mpp_ini_znl( knum ) 1862 INTEGER :: knum 1863 WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 1864 END SUBROUTINE mpp_ini_znl 1865 1866 SUBROUTINE mpp_comm_free( kcom ) 1867 INTEGER :: kcom 1868 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 1869 END SUBROUTINE mpp_comm_free 1870 1871 #endif 1872 1873 !!---------------------------------------------------------------------- 1874 !! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1063 FUNCTION MPI_Wtime() 1064 REAL(wp) :: MPI_Wtime 1065 MPI_Wtime = -1. 1066 END FUNCTION MPI_Wtime 1067 #endif 1068 1069 !!---------------------------------------------------------------------- 1070 !! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1875 1071 !!---------------------------------------------------------------------- 1876 1072 … … 1883 1079 !! increment the error number (nstop) by one. 1884 1080 !!---------------------------------------------------------------------- 1885 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 1886 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1081 CHARACTER(len=*), INTENT(in ) :: cd1 1082 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5 1083 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1887 1084 !!---------------------------------------------------------------------- 1888 1085 ! 1889 1086 nstop = nstop + 1 1890 1891 ! force to open ocean.output file 1087 ! 1088 ! force to open ocean.output file if not already opened 1892 1089 IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 1893 1894 WRITE(numout,cform_err) 1895 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1090 ! 1091 WRITE(numout,*) 1092 WRITE(numout,*) ' ===>>> : E R R O R' 1093 WRITE(numout,*) 1094 WRITE(numout,*) ' ===========' 1095 WRITE(numout,*) 1096 WRITE(numout,*) TRIM(cd1) 1896 1097 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1897 1098 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) … … 1903 1104 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1904 1105 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1905 1106 WRITE(numout,*) 1107 ! 1906 1108 CALL FLUSH(numout ) 1907 1109 IF( numstp /= -1 ) CALL FLUSH(numstp ) … … 1910 1112 ! 1911 1113 IF( cd1 == 'STOP' ) THEN 1114 WRITE(numout,*) 1912 1115 WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' 1913 CALL mppstop(ld_force_abort = .true.) 1116 WRITE(numout,*) 1117 CALL mppstop( ld_abort = .true. ) 1914 1118 ENDIF 1915 1119 ! … … 1930 1134 ! 1931 1135 nwarn = nwarn + 1 1136 ! 1932 1137 IF(lwp) THEN 1933 WRITE(numout,cform_war) 1934 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1935 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1936 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1937 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1938 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1939 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1940 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1941 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1942 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1943 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1138 WRITE(numout,*) 1139 WRITE(numout,*) ' ===>>> : W A R N I N G' 1140 WRITE(numout,*) 1141 WRITE(numout,*) ' ===============' 1142 WRITE(numout,*) 1143 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1144 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1145 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1146 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1147 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1148 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1149 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1150 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1151 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1152 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1153 WRITE(numout,*) 1944 1154 ENDIF 1945 1155 CALL FLUSH(numout) … … 1984 1194 IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null 1985 1195 ! 1986 iost=0 1987 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1196 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1988 1197 OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost ) 1989 1198 ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters … … 2006 1215 100 CONTINUE 2007 1216 IF( iost /= 0 ) THEN 2008 IF(ldwp) THEN 2009 WRITE(kout,*) 2010 WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 2011 WRITE(kout,*) ' ======= === ' 2012 WRITE(kout,*) ' unit = ', knum 2013 WRITE(kout,*) ' status = ', cdstat 2014 WRITE(kout,*) ' form = ', cdform 2015 WRITE(kout,*) ' access = ', cdacce 2016 WRITE(kout,*) ' iostat = ', iost 2017 WRITE(kout,*) ' we stop. verify the file ' 2018 WRITE(kout,*) 2019 ELSE !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 2020 WRITE(*,*) 2021 WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 2022 WRITE(*,*) ' ======= === ' 2023 WRITE(*,*) ' unit = ', knum 2024 WRITE(*,*) ' status = ', cdstat 2025 WRITE(*,*) ' form = ', cdform 2026 WRITE(*,*) ' access = ', cdacce 2027 WRITE(*,*) ' iostat = ', iost 2028 WRITE(*,*) ' we stop. verify the file ' 2029 WRITE(*,*) 2030 ENDIF 2031 CALL FLUSH( kout ) 2032 STOP 'ctl_opn bad opening' 1217 WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 1218 WRITE(ctmp2,*) ' ======= === ' 1219 WRITE(ctmp3,*) ' unit = ', knum 1220 WRITE(ctmp4,*) ' status = ', cdstat 1221 WRITE(ctmp5,*) ' form = ', cdform 1222 WRITE(ctmp6,*) ' access = ', cdacce 1223 WRITE(ctmp7,*) ' iostat = ', iost 1224 WRITE(ctmp8,*) ' we stop. verify the file ' 1225 CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 2033 1226 ENDIF 2034 1227 ! … … 2036 1229 2037 1230 2038 SUBROUTINE ctl_nam ( kios, cdnam , ldwp)1231 SUBROUTINE ctl_nam ( kios, cdnam ) 2039 1232 !!---------------------------------------------------------------------- 2040 1233 !! *** ROUTINE ctl_nam *** … … 2044 1237 !! ** Method : Fortan open 2045 1238 !!---------------------------------------------------------------------- 2046 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist2047 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs2048 CHARACTER(len=5) :: clios ! string to convert iostat in character for print2049 LOGICAL , INTENT(in ) :: ldwp ! boolean termfor print1239 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 1240 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs 1241 ! 1242 CHARACTER(len=5) :: clios ! string to convert iostat in character for print 2050 1243 !!---------------------------------------------------------------------- 2051 1244 ! … … 2061 1254 ENDIF 2062 1255 kios = 0 2063 RETURN2064 1256 ! 2065 1257 END SUBROUTINE ctl_nam … … 2082 1274 END DO 2083 1275 IF( (get_unit == 999) .AND. llopn ) THEN 2084 CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 2085 get_unit = -1 1276 CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 2086 1277 ENDIF 2087 1278 ! -
NEMO/trunk/src/OCE/LBC/mpp_lnk_generic.h90
r10542 r11536 46 46 47 47 #if defined MULTI 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval)49 INTEGER 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 49 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 50 50 #else 51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , cd_mpp, pval)51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv, ihlcom ) 52 52 #endif 53 53 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 54 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 55 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 56 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 57 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 58 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 59 ! 60 INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices 54 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 55 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 56 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 57 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 58 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 59 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 60 INTEGER ,OPTIONAL, INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated 61 ! 62 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 61 63 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 62 INTEGER :: i migr, iihom, ijhom! local integers63 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend64 INTEGER :: isize, ishift, ishift2 ! local integers 65 INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id 64 66 INTEGER :: ierr 67 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 68 INTEGER :: ihl ! number of ranks and rows to be communicated 65 69 REAL(wp) :: zland 66 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 67 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! north-south & south-north halos 68 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! east -west & west - east halos 70 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 71 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 72 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 73 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 74 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive 75 LOGICAL :: lldo_nfd ! do north pole folding 69 76 !!---------------------------------------------------------------------- 77 ! 78 ! ----------------------------------------- ! 79 ! 0. local variables initialization ! 80 ! ----------------------------------------- ! 70 81 ! 71 82 ipk = K_SIZE(ptab) ! 3rd dimension … … 73 84 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 74 85 ! 86 IF( PRESENT(ihlcom) ) THEN ; ihl = ihlcom 87 ELSE ; ihl = 1 88 END IF 89 ! 75 90 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 76 91 ! 77 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 78 ELSE ; zland = 0._wp ! zero by default 79 ENDIF 80 81 ! ------------------------------- ! 82 ! standard boundary treatment ! ! CAUTION: semi-column notation is often impossible 83 ! ------------------------------- ! 84 ! 85 IF( .NOT. PRESENT( cd_mpp ) ) THEN !== standard close or cyclic treatment ==! 86 ! 87 DO jf = 1, ipf ! number of arrays to be treated 88 ! 89 ! ! East-West boundaries 90 IF( l_Iperio ) THEN !* cyclic 91 ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf) 92 ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN( 2 ,:,:,:,jf) 93 ELSE !* closed 94 IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN( 1 :nn_hls,:,:,:,jf) = zland ! east except F-point 95 ARRAY_IN(nlci-nn_hls+1:jpi ,:,:,:,jf) = zland ! west 96 ENDIF 97 ! ! North-South boundaries 98 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 99 ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf) 100 ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:, 2 ,:,:,jf) 101 ELSE !* closed 102 IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(:, 1 :nn_hls,:,:,jf) = zland ! south except F-point 103 ARRAY_IN(:,nlcj-nn_hls+1:jpj ,:,:,jf) = zland ! north 92 IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN 93 llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4) 94 llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4) 95 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 96 WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' 97 WRITE(ctmp2,*) ' ========== ' 98 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 99 ELSE ! send and receive with every neighbour 100 llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 101 llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 102 llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 103 llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 104 llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no 105 END IF 106 107 108 lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini 109 110 zland = 0._wp ! land filling value: zero by default 111 IF( PRESENT( pfillval ) ) zland = pfillval ! set land value 112 113 ! define the method we will use to fill the halos in each direction 114 IF( llrecv_we ) THEN ; ifill_we = jpfillmpi 115 ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio 116 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode 117 ELSE ; ifill_we = jpfillcst 118 END IF 119 ! 120 IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi 121 ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio 122 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode 123 ELSE ; ifill_ea = jpfillcst 124 END IF 125 ! 126 IF( llrecv_so ) THEN ; ifill_so = jpfillmpi 127 ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio 128 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode 129 ELSE ; ifill_so = jpfillcst 130 END IF 131 ! 132 IF( llrecv_no ) THEN ; ifill_no = jpfillmpi 133 ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio 134 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode 135 ELSE ; ifill_no = jpfillcst 136 END IF 137 ! 138 #if defined PRINT_CAUTION 139 ! 140 ! ================================================================================== ! 141 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 142 ! ================================================================================== ! 143 ! 144 #endif 145 ! 146 ! -------------------------------------------------- ! 147 ! 1. Do east and west MPI exchange if needed ! 148 ! -------------------------------------------------- ! 149 ! 150 ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 151 isize = ihl * jpj * ipk * ipl * ipf 152 ! 153 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 154 IF( llsend_we ) ALLOCATE( zsnd_we(ihl,jpj,ipk,ipl,ipf) ) 155 IF( llsend_ea ) ALLOCATE( zsnd_ea(ihl,jpj,ipk,ipl,ipf) ) 156 IF( llrecv_we ) ALLOCATE( zrcv_we(ihl,jpj,ipk,ipl,ipf) ) 157 IF( llrecv_ea ) ALLOCATE( zrcv_ea(ihl,jpj,ipk,ipl,ipf) ) 158 ! 159 IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 160 ishift = ihl 161 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 162 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! ihl + 1 -> 2*ihl 163 END DO ; END DO ; END DO ; END DO ; END DO 164 ENDIF 165 ! 166 IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 167 ishift = jpi - 2 * ihl 168 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 169 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*ihl + 1 -> jpi - ihl 170 END DO ; END DO ; END DO ; END DO ; END DO 171 ENDIF 172 ! 173 IF( ln_timing ) CALL tic_tac(.TRUE.) 174 ! 175 ! non-blocking send of the western/eastern side using local temporary arrays 176 IF( llsend_we ) CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 177 IF( llsend_ea ) CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 178 ! blocking receive of the western/eastern halo in local temporary arrays 179 IF( llrecv_we ) CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 180 IF( llrecv_ea ) CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 181 ! 182 IF( ln_timing ) CALL tic_tac(.FALSE.) 183 ! 184 ! 185 ! ----------------------------------- ! 186 ! 2. Fill east and west halos ! 187 ! ----------------------------------- ! 188 ! 189 ! 2.1 fill weastern halo 190 ! ---------------------- 191 ! ishift = 0 ! fill halo from ji = 1 to ihl 192 SELECT CASE ( ifill_we ) 193 CASE ( jpfillnothing ) ! no filling 194 CASE ( jpfillmpi ) ! use data received by MPI 195 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 196 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> ihl 197 END DO; END DO ; END DO ; END DO ; END DO 198 CASE ( jpfillperio ) ! use east-weast periodicity 199 ishift2 = jpi - 2 * ihl 200 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 201 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 202 END DO; END DO ; END DO ; END DO ; END DO 203 CASE ( jpfillcopy ) ! filling with inner domain values 204 DO jf = 1, ipf ! number of arrays to be treated 205 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 206 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 207 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) 208 END DO ; END DO ; END DO ; END DO 104 209 ENDIF 105 210 END DO 106 ! 107 ENDIF 108 109 ! ------------------------------- ! 110 ! East and west exchange ! 111 ! ------------------------------- ! 112 ! we play with the neigbours AND the row number because of the periodicity 113 ! 114 IF( ABS(nbondi) == 1 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,1), zt3we(jpj,nn_hls,ipk,ipl,ipf,1) ) 115 IF( nbondi == 0 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2) ) 116 ! 117 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 118 CASE ( -1 ) 119 iihom = nlci-nreci 120 DO jf = 1, ipf 121 DO jl = 1, ipl 122 DO jk = 1, ipk 123 DO jh = 1, nn_hls 124 zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 125 END DO 126 END DO 127 END DO 128 END DO 129 CASE ( 0 ) 130 iihom = nlci-nreci 131 DO jf = 1, ipf 132 DO jl = 1, ipl 133 DO jk = 1, ipk 134 DO jh = 1, nn_hls 135 zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 136 zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 137 END DO 138 END DO 139 END DO 140 END DO 141 CASE ( 1 ) 142 iihom = nlci-nreci 143 DO jf = 1, ipf 144 DO jl = 1, ipl 145 DO jk = 1, ipk 146 DO jh = 1, nn_hls 147 zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 148 END DO 149 END DO 150 END DO 211 CASE ( jpfillcst ) ! filling with constant value 212 DO jf = 1, ipf ! number of arrays to be treated 213 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 214 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 215 ARRAY_IN(ji,jj,jk,jl,jf) = zland 216 END DO; END DO ; END DO ; END DO 217 ENDIF 151 218 END DO 152 219 END SELECT 153 ! ! Migrations 154 imigr = nn_hls * jpj * ipk * ipl * ipf 155 ! 156 IF( ln_timing ) CALL tic_tac(.TRUE.) 157 ! 158 SELECT CASE ( nbondi ) 159 CASE ( -1 ) 160 CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 ) 161 CALL mpprecv( 1, zt3ew(1,1,1,1,1,1), imigr, noea ) 162 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 163 CASE ( 0 ) 164 CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 165 CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 ) 166 CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea ) 167 CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe ) 168 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 169 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 170 CASE ( 1 ) 171 CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 172 CALL mpprecv( 2, zt3we(1,1,1,1,1,1), imigr, nowe ) 173 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 220 ! 221 ! 2.2 fill eastern halo 222 ! --------------------- 223 ishift = jpi - ihl ! fill halo from ji = jpi-ihl+1 to jpi 224 SELECT CASE ( ifill_ea ) 225 CASE ( jpfillnothing ) ! no filling 226 CASE ( jpfillmpi ) ! use data received by MPI 227 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 228 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - ihl + 1 -> jpi 229 END DO ; END DO ; END DO ; END DO ; END DO 230 CASE ( jpfillperio ) ! use east-weast periodicity 231 ishift2 = ihl 232 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 233 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 234 END DO ; END DO ; END DO ; END DO ; END DO 235 CASE ( jpfillcopy ) ! filling with inner domain values 236 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 237 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 238 END DO ; END DO ; END DO ; END DO ; END DO 239 CASE ( jpfillcst ) ! filling with constant value 240 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 241 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 242 END DO; END DO ; END DO ; END DO ; END DO 174 243 END SELECT 175 !176 IF( ln_timing ) CALL tic_tac(.FALSE.)177 !178 ! ! Write Dirichlet lateral conditions179 iihom = nlci-nn_hls180 !181 SELECT CASE ( nbondi )182 CASE ( -1 )183 DO jf = 1, ipf184 DO jl = 1, ipl185 DO jk = 1, ipk186 DO jh = 1, nn_hls187 ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,1)188 END DO189 END DO190 END DO191 END DO192 CASE ( 0 )193 DO jf = 1, ipf194 DO jl = 1, ipl195 DO jk = 1, ipk196 DO jh = 1, nn_hls197 ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)198 ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)199 END DO200 END DO201 END DO202 END DO203 CASE ( 1 )204 DO jf = 1, ipf205 DO jl = 1, ipl206 DO jk = 1, ipk207 DO jh = 1, nn_hls208 ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,1)209 END DO210 END DO211 END DO212 END DO213 END SELECT214 !215 IF( nbondi /= 2 ) DEALLOCATE( zt3ew, zt3we )216 244 ! 217 245 ! ------------------------------- ! 218 246 ! 3. north fold treatment ! 219 247 ! ------------------------------- ! 248 ! 220 249 ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor 221 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 250 ! 251 IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN 222 252 ! 223 253 SELECT CASE ( jpni ) … … 226 256 END SELECT 227 257 ! 228 ENDIF 229 ! 230 ! ------------------------------- ! 231 ! 4. North and south directions ! 232 ! ------------------------------- ! 233 ! always closed : we play only with the neigbours 234 ! 235 IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) ) 236 IF( nbondj == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) ) 237 ! 238 SELECT CASE ( nbondj ) 239 CASE ( -1 ) 240 ijhom = nlcj-nrecj 241 DO jf = 1, ipf 242 DO jl = 1, ipl 243 DO jk = 1, ipk 244 DO jh = 1, nn_hls 245 zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 246 END DO 247 END DO 248 END DO 258 ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding 259 ! 260 ENDIF 261 ! 262 ! ---------------------------------------------------- ! 263 ! 4. Do north and south MPI exchange if needed ! 264 ! ---------------------------------------------------- ! 265 ! 266 IF( llsend_so ) ALLOCATE( zsnd_so(jpi,ihl,ipk,ipl,ipf) ) 267 IF( llsend_no ) ALLOCATE( zsnd_no(jpi,ihl,ipk,ipl,ipf) ) 268 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,ihl,ipk,ipl,ipf) ) 269 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,ihl,ipk,ipl,ipf) ) 270 ! 271 isize = jpi * ihl * ipk * ipl * ipf 272 273 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 274 IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 275 ishift = ihl 276 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 277 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! ihl+1 -> 2*ihl 278 END DO ; END DO ; END DO ; END DO ; END DO 279 ENDIF 280 ! 281 IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 282 ishift = jpj - 2 * ihl 283 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 284 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*ihl+1 -> jpj-ihl 285 END DO ; END DO ; END DO ; END DO ; END DO 286 ENDIF 287 ! 288 IF( ln_timing ) CALL tic_tac(.TRUE.) 289 ! 290 ! non-blocking send of the southern/northern side 291 IF( llsend_so ) CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 292 IF( llsend_no ) CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 293 ! blocking receive of the southern/northern halo 294 IF( llrecv_so ) CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso ) 295 IF( llrecv_no ) CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono ) 296 ! 297 IF( ln_timing ) CALL tic_tac(.FALSE.) 298 ! 299 ! ------------------------------------- ! 300 ! 5. Fill south and north halos ! 301 ! ------------------------------------- ! 302 ! 303 ! 5.1 fill southern halo 304 ! ---------------------- 305 ! ishift = 0 ! fill halo from jj = 1 to ihl 306 SELECT CASE ( ifill_so ) 307 CASE ( jpfillnothing ) ! no filling 308 CASE ( jpfillmpi ) ! use data received by MPI 309 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 310 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> ihl 311 END DO; END DO ; END DO ; END DO ; END DO 312 CASE ( jpfillperio ) ! use north-south periodicity 313 ishift2 = jpj - 2 * ihl 314 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 315 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 316 END DO; END DO ; END DO ; END DO ; END DO 317 CASE ( jpfillcopy ) ! filling with inner domain values 318 DO jf = 1, ipf ! number of arrays to be treated 319 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 320 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 321 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) 322 END DO ; END DO ; END DO ; END DO 323 ENDIF 249 324 END DO 250 CASE ( 0 ) 251 ijhom = nlcj-nrecj 252 DO jf = 1, ipf 253 DO jl = 1, ipl 254 DO jk = 1, ipk 255 DO jh = 1, nn_hls 256 zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 257 zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 258 END DO 259 END DO 260 END DO 261 END DO 262 CASE ( 1 ) 263 ijhom = nlcj-nrecj 264 DO jf = 1, ipf 265 DO jl = 1, ipl 266 DO jk = 1, ipk 267 DO jh = 1, nn_hls 268 zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 269 END DO 270 END DO 271 END DO 325 CASE ( jpfillcst ) ! filling with constant value 326 DO jf = 1, ipf ! number of arrays to be treated 327 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 328 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 329 ARRAY_IN(ji,jj,jk,jl,jf) = zland 330 END DO; END DO ; END DO ; END DO 331 ENDIF 272 332 END DO 273 333 END SELECT 274 334 ! 275 ! ! Migrations 276 imigr = nn_hls * jpi * ipk * ipl * ipf 277 ! 278 IF( ln_timing ) CALL tic_tac(.TRUE.) 279 ! 280 SELECT CASE ( nbondj ) 281 CASE ( -1 ) 282 CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 ) 283 CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono ) 284 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 285 CASE ( 0 ) 286 CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 287 CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 ) 288 CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono ) 289 CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso ) 290 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 291 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 292 CASE ( 1 ) 293 CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 294 CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso ) 295 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 335 ! 5.2 fill northern halo 336 ! ---------------------- 337 ishift = jpj - ihl ! fill halo from jj = jpj-ihl+1 to jpj 338 SELECT CASE ( ifill_no ) 339 CASE ( jpfillnothing ) ! no filling 340 CASE ( jpfillmpi ) ! use data received by MPI 341 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 342 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-ihl+1 -> jpj 343 END DO ; END DO ; END DO ; END DO ; END DO 344 CASE ( jpfillperio ) ! use north-south periodicity 345 ishift2 = ihl 346 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 347 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 348 END DO; END DO ; END DO ; END DO ; END DO 349 CASE ( jpfillcopy ) ! filling with inner domain values 350 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 351 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 352 END DO; END DO ; END DO ; END DO ; END DO 353 CASE ( jpfillcst ) ! filling with constant value 354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 355 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 356 END DO; END DO ; END DO ; END DO ; END DO 296 357 END SELECT 297 358 ! 298 IF( ln_timing ) CALL tic_tac(.FALSE.) 299 ! ! Write Dirichlet lateral conditions 300 ijhom = nlcj-nn_hls 301 ! 302 SELECT CASE ( nbondj ) 303 CASE ( -1 ) 304 DO jf = 1, ipf 305 DO jl = 1, ipl 306 DO jk = 1, ipk 307 DO jh = 1, nn_hls 308 ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1) 309 END DO 310 END DO 311 END DO 312 END DO 313 CASE ( 0 ) 314 DO jf = 1, ipf 315 DO jl = 1, ipl 316 DO jk = 1, ipk 317 DO jh = 1, nn_hls 318 ARRAY_IN(:, jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 319 ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 320 END DO 321 END DO 322 END DO 323 END DO 324 CASE ( 1 ) 325 DO jf = 1, ipf 326 DO jl = 1, ipl 327 DO jk = 1, ipk 328 DO jh = 1, nn_hls 329 ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1) 330 END DO 331 END DO 332 END DO 333 END DO 334 END SELECT 335 ! 336 IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn ) 359 ! -------------------------------------------- ! 360 ! 6. deallocate local temporary arrays ! 361 ! -------------------------------------------- ! 362 ! 363 IF( llsend_we ) THEN 364 CALL mpi_wait(ireq_we, istat, ierr ) 365 DEALLOCATE( zsnd_we ) 366 ENDIF 367 IF( llsend_ea ) THEN 368 CALL mpi_wait(ireq_ea, istat, ierr ) 369 DEALLOCATE( zsnd_ea ) 370 ENDIF 371 IF( llsend_so ) THEN 372 CALL mpi_wait(ireq_so, istat, ierr ) 373 DEALLOCATE( zsnd_so ) 374 ENDIF 375 IF( llsend_no ) THEN 376 CALL mpi_wait(ireq_no, istat, ierr ) 377 DEALLOCATE( zsnd_no ) 378 ENDIF 379 ! 380 IF( llrecv_we ) DEALLOCATE( zrcv_we ) 381 IF( llrecv_ea ) DEALLOCATE( zrcv_ea ) 382 IF( llrecv_so ) DEALLOCATE( zrcv_so ) 383 IF( llrecv_no ) DEALLOCATE( zrcv_no ) 337 384 ! 338 385 END SUBROUTINE ROUTINE_LNK -
NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90
r10440 r11536 76 76 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 77 77 ! 78 IF( l_north_nogather ) THEN !== ????==!78 IF( l_north_nogather ) THEN !== no allgather exchanges ==! 79 79 80 80 ALLOCATE(ipj_s(ipf)) … … 200 200 ENDIF 201 201 END DO 202 IF( l_isend ) THEN 203 DO jr = 1,nsndto 204 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 205 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 206 ENDIF 207 END DO 208 ENDIF 202 DO jr = 1,nsndto 203 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 204 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 205 ENDIF 206 END DO 209 207 ! 210 208 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 213 211 ! 214 212 DO jf = 1, ipf 215 CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 216 END DO 217 ! 218 DEALLOCATE( zfoldwk ) 219 DEALLOCATE( ztabr ) 220 DEALLOCATE( jj_s ) 221 DEALLOCATE( ipj_s ) 222 ELSE !== ???? ==! 213 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 214 END DO 215 ! 216 DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 217 ! 218 ELSE !== allgather exchanges ==! 223 219 ! 224 220 ipj = 4 ! 2nd dimension of message transfers (last j-lines) -
NEMO/trunk/src/OCE/LBC/mppini.F90
r11242 r11536 84 84 nbondj = 2 85 85 nidom = FLIO_DOM_NONE 86 npolj = jperio 86 npolj = 0 87 IF( jperio == 3 .OR. jperio == 4 ) npolj = 3 88 IF( jperio == 5 .OR. jperio == 6 ) npolj = 5 87 89 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 88 90 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) … … 152 154 LOGICAL :: llbest, llauto 153 155 LOGICAL :: llwrtlay 156 LOGICAL :: ln_listonly 154 157 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 155 158 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - … … 164 167 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 165 168 & cn_ice, nn_ice_dta, & 166 & rn_ice_tem, rn_ice_sal, rn_ice_age, &167 & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy168 !!---------------------------------------------------------------------- 169 169 & ln_vol, nn_volctl, nn_rimwidth 170 NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly 171 !!---------------------------------------------------------------------- 172 ! 170 173 llwrtlay = lwp .OR. ln_ctl .OR. sn_cfctl%l_layout 174 ! 175 ! 0. read namelists parameters 176 ! ----------------------------------- 177 ! 178 REWIND( numnam_ref ) ! Namelist nammpp in reference namelist 179 READ ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 ) 180 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist' ) 181 REWIND( numnam_cfg ) ! Namelist nammpp in confguration namelist 182 READ ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 183 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) 184 ! 185 IF(lwp) THEN 186 WRITE(numout,*) ' Namelist nammpp' 187 IF( jpni < 1 .OR. jpnj < 1 ) THEN 188 WRITE(numout,*) ' jpni and jpnj will be calculated automatically' 189 ELSE 190 WRITE(numout,*) ' processor grid extent in i jpni = ', jpni 191 WRITE(numout,*) ' processor grid extent in j jpnj = ', jpnj 192 ENDIF 193 WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather 194 ENDIF 195 ! 196 IF(lwm) WRITE( numond, nammpp ) 197 171 198 ! do we need to take into account bdy_msk? 172 199 REWIND( numnam_ref ) ! Namelist nambdy in reference namelist : BDY 173 200 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 174 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' , lwp)201 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' ) 175 202 REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist : BDY 176 203 READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 177 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' , lwp)204 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' ) 178 205 ! 179 206 IF( ln_read_cfg ) CALL iom_open( cn_domcfg, numbot ) 180 207 IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 208 ! 209 IF( ln_listonly ) CALL mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core 181 210 ! 182 211 ! 1. Dimension arrays for subdomains … … 241 270 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 242 271 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 243 CALL ctl_stop( 'STOP' )244 272 ENDIF 245 273 … … 266 294 ENDIF 267 295 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 268 CALL ctl_stop( 'STOP' )269 296 ENDIF 270 297 … … 816 843 INTEGER :: isziref, iszjref 817 844 INTEGER :: inbij, iszij 818 INTEGER :: inbimax, inbjmax, inbijmax 845 INTEGER :: inbimax, inbjmax, inbijmax, inbijold 819 846 INTEGER :: isz0, isz1 820 847 INTEGER, DIMENSION( :), ALLOCATABLE :: indexok … … 941 968 DEALLOCATE( indexok, inbi1, inbj1, iszi1, iszj1 ) 942 969 943 IF( llist ) THEN ! we print about 21 best partitions970 IF( llist ) THEN 944 971 IF(lwp) THEN 945 972 WRITE(numout,*) 946 WRITE(numout, 947 WRITE(numout, '(a,i5,a)') ' list of the best partitions around ', knbij, ' mpi processes'948 WRITE(numout, *) ' --------------------------------------', '-----', '--------------'973 WRITE(numout,*) ' For your information:' 974 WRITE(numout,*) ' list of the best partitions including land supression' 975 WRITE(numout,*) ' -----------------------------------------------------' 949 976 WRITE(numout,*) 950 977 END IF 951 iitarget = MINLOC( inbi0(:)*inbj0(:), mask = inbi0(:)*inbj0(:) >= knbij, dim = 1 ) 952 DO ji = MAX(1,iitarget-10), MIN(isz0,iitarget+10) 978 ji = isz0 ! initialization with the largest value 979 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 980 CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum) 981 inbijold = COUNT(llisoce) 982 DEALLOCATE( llisoce ) 983 DO ji =isz0-1,1,-1 953 984 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 954 985 CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum) 955 986 inbij = COUNT(llisoce) 956 987 DEALLOCATE( llisoce ) 957 IF(lwp) WRITE(numout,'(a, i5, a, i5, a, i4, a, i4, a, i9, a, i5, a, i5, a)') & 958 & 'nb_cores ' , inbij,' oce + ', inbi0(ji)*inbj0(ji) - inbij & 959 & , ' land ( ', inbi0(ji),' x ', inbj0(ji), & 960 & ' ), nb_points ', iszi0(ji)*iszj0(ji),' ( ', iszi0(ji),' x ', iszj0(ji),' )' 988 IF(lwp .AND. inbij < inbijold) THEN 989 WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & 990 & 'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij, & 991 & ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100., & 992 & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 993 inbijold = inbij 994 END IF 961 995 END DO 962 996 DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) 963 RETURN 997 IF(lwp) THEN 998 WRITE(numout,*) 999 WRITE(numout,*) ' -----------------------------------------------------------' 1000 ENDIF 1001 CALL mppsync 1002 CALL mppstop( ld_abort = .TRUE. ) 964 1003 ENDIF 965 1004
Note: See TracChangeset
for help on using the changeset viewer.