- Timestamp:
- 2017-06-19T11:25:07+02:00 (7 years ago)
- Location:
- branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 6 added
- 6 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90
r6140 r8186 15 15 16 16 INTERFACE crs_lbc_lnk 17 MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_ 3d_gather, crs_lbc_lnk_2d17 MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_2d 18 18 END INTERFACE 19 19 … … 56 56 ! 57 57 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp, pval=zval ) 58 ELSE ; CALL lbc_lnk( pt3d1, cd_type1, psgn , pval=zval )58 ELSE ; CALL lbc_lnk( pt3d1, cd_type1, psgn , pval=zval ) 59 59 ENDIF 60 60 ! … … 62 62 ! 63 63 END SUBROUTINE crs_lbc_lnk_3d 64 65 66 SUBROUTINE crs_lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )67 !!---------------------------------------------------------------------68 !! *** SUBROUTINE crs_lbc_lnk ***69 !!70 !! ** Purpose : set lateral boundary conditions for coarsened grid71 !!72 !! ** Method : Swap domain indices from full to coarse domain73 !! before arguments are passed directly to lbc_lnk.74 !! Upon exiting, switch back to full domain indices.75 !!----------------------------------------------------------------------76 CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! grid type77 REAL(wp) , INTENT(in ) :: psgn ! control of the sign78 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied79 !80 LOGICAL :: ll_grid_crs81 !!----------------------------------------------------------------------82 !83 ll_grid_crs = ( jpi == jpi_crs )84 !85 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain86 !87 CALL lbc_lnk( pt3d1, cd_type1, pt3d2, cd_type2, psgn )88 !89 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain90 !91 END SUBROUTINE crs_lbc_lnk_3d_gather92 93 64 94 65 … … 121 92 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 122 93 ! 123 IF( PRESENT( cd_mpp ) ) THEN ;CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval )124 ELSE ; CALL lbc_lnk( pt2d, cd_type, psgn,pval=zval )94 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval ) 95 ELSE ; CALL lbc_lnk( pt2d, cd_type, psgn, pval=zval ) 125 96 ENDIF 126 97 ! -
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90
r7646 r8186 184 184 END DO 185 185 186 CALL lbc_sum(pvol_flx(:,:,: ),'T',1.) 187 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 188 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 189 186 !!gm ERROR !!!! 187 !! juste use tmask_i or in case of ISF smask_i (to be created to compute the sum without halos) 188 ! 189 ! CALL lbc_sum(pvol_flx(:,:,: ),'T',1.) 190 ! CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 191 ! CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 192 STOP ' iscpl_cons: please modify this module !' 193 !!gm end 190 194 ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point 191 195 ! allocation and initialisation of the list of problematic point … … 283 287 pts_flx (:,:,:,jp_tem) = pts_flx (:,:,:,jp_tem) * tmask(:,:,:) 284 288 285 ! compute sum over the halo and set it to 0. 286 CALL lbc_sum(pvol_flx(:,:,: ),'T',1._wp) 287 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 288 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 289 !!gm ERROR !!!! 290 !! juste use tmask_i or in case of ISF smask_i (to be created to compute the sum without halos) 291 ! 292 ! ! compute sum over the halo and set it to 0. 293 ! CALL lbc_sum(pvol_flx(:,:,: ),'T',1._wp) 294 ! CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 295 ! CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 296 !!gm end 289 297 290 298 ! deallocate variables -
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r8170 r8186 7 7 !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module 8 8 !! 3.2 ! 2009-03 (R. Benshila) External north fold treatment 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 10 10 !! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case 11 11 !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi 12 12 !! 4.0 ! 2017-03 (G. Madec) automatique allocation of array size (use with any 3rd dim size) 13 13 !! - ! 2017-04 (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather) 14 !! - ! 2017-05 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 14 15 !!---------------------------------------------------------------------- 15 16 #if defined key_mpp_mpi … … 20 21 !!---------------------------------------------------------------------- 21 22 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 22 !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp23 23 !! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 24 24 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 25 25 !!---------------------------------------------------------------------- 26 USE par_oce ! ocean dynamics and tracers 26 27 USE lib_mpp ! distributed memory computing library 27 28 USE lbcnfd ! north fold 29 30 INTERFACE lbc_lnk 31 MODULE PROCEDURE mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 32 END INTERFACE 33 INTERFACE lbc_lnk_ptr 34 MODULE PROCEDURE mpp_lnk_2d_ptr , mpp_lnk_3d_ptr , mpp_lnk_4d_ptr 35 END INTERFACE 28 36 INTERFACE lbc_lnk_multi 29 MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 30 END INTERFACE 31 ! 32 INTERFACE lbc_lnk 33 MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 34 END INTERFACE 35 ! 36 INTERFACE lbc_sum 37 MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 37 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 38 38 END INTERFACE 39 39 ! … … 52 52 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 53 53 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 54 PUBLIC lbc_sum ! sum across processors55 54 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions 56 55 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions … … 62 61 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 63 62 !!---------------------------------------------------------------------- 63 CONTAINS 64 64 65 #else 65 66 !!---------------------------------------------------------------------- … … 69 70 !! on first and last row and column of the global domain 70 71 !!---------------------------------------------------------------------- 71 !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d72 72 !! lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 73 73 !! lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh … … 86 86 87 87 INTERFACE lbc_lnk 88 MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d 89 END INTERFACE 90 ! 91 INTERFACE lbc_sum 92 MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 88 MODULE PROCEDURE lbc_lnk_2d , lbc_lnk_3d , lbc_lnk_4d 89 END INTERFACE 90 INTERFACE lbc_lnk_ptr 91 MODULE PROCEDURE lbc_lnk_2d_ptr , lbc_lnk_3d_ptr , lbc_lnk_4d_ptr 92 END INTERFACE 93 INTERFACE lbc_lnk_multi 94 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 93 95 END INTERFACE 94 96 ! … … 97 99 END INTERFACE 98 100 ! 99 INTERFACE lbc_lnk_multi100 MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple101 END INTERFACE102 !103 101 INTERFACE lbc_bdy_lnk 104 102 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 109 107 END INTERFACE 110 108 111 TYPE arrayptr112 REAL , DIMENSION (:,:), POINTER :: pt2d113 END TYPE arrayptr114 !115 PUBLIC arrayptr116 117 109 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 118 PUBLIC lbc_sum ! ocean/ice lateral boundary conditions (sum of the overlap region)119 110 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions 120 111 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions … … 130 121 131 122 # if defined key_c1d 132 !! ----------------------------------------------------------------------123 !!====================================================================== 133 124 !! 'key_c1d' 1D configuration 134 !! ----------------------------------------------------------------------125 !!====================================================================== 135 126 !! central point value replicated over the 8 surrounding points 136 127 !!---------------------------------------------------------------------- … … 185 176 186 177 #else 187 !! ----------------------------------------------------------------------178 !!====================================================================== 188 179 !! Default option 3D shared memory computing 189 !! ----------------------------------------------------------------------180 !!====================================================================== 190 181 !! routines setting land point, or east-west cyclic, 191 182 !! or north-south cyclic, or north fold values … … 193 184 !!---------------------------------------------------------------------- 194 185 195 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 196 !!--------------------------------------------------------------------- 197 !! *** ROUTINE lbc_lnk_3d *** 198 !! 199 !! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case) 200 !! 201 !! ** Method : psign = -1 : change the sign across the north fold 202 !! = 1 : no change of the sign across the north fold 203 !! = 0 : no change of the sign across the north fold and 204 !! strict positivity preserved: use inner row/column 205 !! for closed boundaries. 206 !!---------------------------------------------------------------------- 207 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 208 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 209 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 210 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 211 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 212 ! 213 REAL(wp) :: zland 214 !!---------------------------------------------------------------------- 215 ! 216 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 217 ELSE ; zland = 0._wp 218 ENDIF 219 ! 220 IF( PRESENT( cd_mpp ) ) THEN 221 ! only fill the overlap area and extra allows 222 ! this is in mpp case. In this module, just do nothing 223 ELSE 224 ! ! East-West boundaries 225 ! ! ====================== 226 SELECT CASE ( nperio ) 227 ! 228 CASE ( 1 , 4 , 6 ) !** cyclic east-west 229 pt3d( 1 ,:,:) = pt3d(jpim1,:,:) ! all points 230 pt3d(jpi,:,:) = pt3d( 2 ,:,:) 231 ! 232 CASE DEFAULT !** East closed -- West closed 233 SELECT CASE ( cd_type ) 234 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 235 pt3d( 1 ,:,:) = zland 236 pt3d(jpi,:,:) = zland 237 CASE ( 'F' ) ! F-point 238 pt3d(jpi,:,:) = zland 239 END SELECT 240 ! 241 END SELECT 242 ! ! North-South boundaries 243 ! ! ====================== 244 SELECT CASE ( nperio ) 245 ! 246 CASE ( 2 ) !** South symmetric -- North closed 247 SELECT CASE ( cd_type ) 248 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 249 pt3d(:, 1 ,:) = pt3d(:,3,:) 250 pt3d(:,jpj,:) = zland 251 CASE ( 'V' , 'F' ) ! V-, F-points 252 pt3d(:, 1 ,:) = psgn * pt3d(:,2,:) 253 pt3d(:,jpj,:) = zland 254 END SELECT 255 ! 256 CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed 257 SELECT CASE ( cd_type ) ! South : closed 258 CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point 259 pt3d(:, 1 ,:) = zland 260 END SELECT 261 ! ! North fold 262 CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn ) 263 ! 264 CASE DEFAULT !** North closed -- South closed 265 SELECT CASE ( cd_type ) 266 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 267 pt3d(:, 1 ,:) = zland 268 pt3d(:,jpj,:) = zland 269 CASE ( 'F' ) ! F-point 270 pt3d(:,jpj,:) = zland 271 END SELECT 272 ! 273 END SELECT 274 ! 275 ENDIF 276 ! 277 END SUBROUTINE lbc_lnk_3d 278 279 280 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 281 !!--------------------------------------------------------------------- 282 !! *** ROUTINE lbc_lnk_2d *** 283 !! 284 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case) 285 !! 286 !! ** Method : psign = -1 : change the sign across the north fold 287 !! = 1 : no change of the sign across the north fold 288 !! = 0 : no change of the sign across the north fold and 289 !! strict positivity preserved: use inner row/column 290 !! for closed boundaries. 291 !!---------------------------------------------------------------------- 292 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 293 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 294 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 295 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 296 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 297 !! 298 REAL(wp) :: zland 299 !!---------------------------------------------------------------------- 300 301 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 302 ELSE ; zland = 0._wp 303 ENDIF 304 305 IF (PRESENT(cd_mpp)) THEN 306 ! only fill the overlap area and extra allows 307 ! this is in mpp case. In this module, just do nothing 308 ELSE 309 ! ! East-West boundaries 310 ! ! ==================== 311 SELECT CASE ( nperio ) 312 ! 313 CASE ( 1 , 4 , 6 ) !** cyclic east-west 314 pt2d( 1 ,:) = pt2d(jpim1,:) ! all points 315 pt2d(jpi,:) = pt2d( 2 ,:) 316 ! 317 CASE DEFAULT !** East closed -- West closed 318 SELECT CASE ( cd_type ) 319 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 320 pt2d( 1 ,:) = zland 321 pt2d(jpi,:) = zland 322 CASE ( 'F' ) ! F-point 323 pt2d(jpi,:) = zland 324 END SELECT 325 ! 326 END SELECT 327 ! ! North-South boundaries 328 ! ! ====================== 329 SELECT CASE ( nperio ) 330 ! 331 CASE ( 2 ) !** South symmetric -- North closed 332 SELECT CASE ( cd_type ) 333 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 334 pt2d(:, 1 ) = pt2d(:,3) 335 pt2d(:,jpj) = zland 336 CASE ( 'V' , 'F' ) ! V-, F-points 337 pt2d(:, 1 ) = psgn * pt2d(:,2) 338 pt2d(:,jpj) = zland 339 END SELECT 340 ! 341 CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed 342 SELECT CASE ( cd_type ) ! South : closed 343 CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point 344 pt2d(:, 1 ) = zland 345 END SELECT 346 ! ! North fold 347 CALL lbc_nfd( pt2d(:,:), cd_type, psgn ) 348 ! 349 CASE DEFAULT !** North closed -- South closed 350 SELECT CASE ( cd_type ) 351 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 352 pt2d(:, 1 ) = zland 353 pt2d(:,jpj) = zland 354 CASE ( 'F' ) ! F-point 355 pt2d(:,jpj) = zland 356 END SELECT 357 ! 358 END SELECT 359 ! 360 ENDIF 361 ! 362 END SUBROUTINE lbc_lnk_2d 186 !!---------------------------------------------------------------------- 187 !! *** routine lbc_lnk_(2,3,4)d *** 188 !! 189 !! * Argument : dummy argument use in lbc_lnk_... routines 190 !! ptab : array or pointer of arrays on which the boundary condition is applied 191 !! cd_nat : nature of array grid-points 192 !! psgn : sign used across the north fold boundary 193 !! kfld : optional, number of pt3d arrays 194 !! cd_mpp : optional, fill the overlap area only 195 !! pval : optional, background value (used at closed boundaries) 196 !!---------------------------------------------------------------------- 197 ! 198 ! !== 2D array and array of 2D pointer ==! 199 ! 200 # define DIM_2d 201 # define ROUTINE_LNK lbc_lnk_2d 202 # include "lbc_lnk_generic.h90" 203 # undef ROUTINE_LNK 204 # define MULTI 205 # define ROUTINE_LNK lbc_lnk_2d_ptr 206 # include "lbc_lnk_generic.h90" 207 # undef ROUTINE_LNK 208 # undef MULTI 209 # undef DIM_2d 210 ! 211 ! !== 3D array and array of 3D pointer ==! 212 ! 213 # define DIM_3d 214 # define ROUTINE_LNK lbc_lnk_3d 215 # include "lbc_lnk_generic.h90" 216 # undef ROUTINE_LNK 217 # define MULTI 218 # define ROUTINE_LNK lbc_lnk_3d_ptr 219 # include "lbc_lnk_generic.h90" 220 # undef ROUTINE_LNK 221 # undef MULTI 222 # undef DIM_3d 223 ! 224 ! !== 4D array and array of 4D pointer ==! 225 ! 226 # define DIM_4d 227 # define ROUTINE_LNK lbc_lnk_4d 228 # include "lbc_lnk_generic.h90" 229 # undef ROUTINE_LNK 230 # define MULTI 231 # define ROUTINE_LNK lbc_lnk_4d_ptr 232 # include "lbc_lnk_generic.h90" 233 # undef ROUTINE_LNK 234 # undef MULTI 235 # undef DIM_4d 363 236 364 237 #endif 365 238 366 !!---------------------------------------------------------------------- 367 !! identical routines in both C1D and shared memory computing cases 368 !!---------------------------------------------------------------------- 369 370 SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 371 !!--------------------------------------------------------------------- 372 !! *** ROUTINE lbc_lnk_3d_gather *** 373 !! 374 !! ** Purpose : set lateral boundary conditions on two 3D arrays (C1D case) 375 !! 376 !! ** Method : call lbc_lnk_3d on pt3d1 and pt3d2 377 !!---------------------------------------------------------------------- 378 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied 379 CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! nature of pt3d1 & pt3d2 grid-points 380 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 381 !!---------------------------------------------------------------------- 382 ! 383 CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 384 CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 385 ! 386 END SUBROUTINE lbc_lnk_3d_gather 387 388 389 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld ) 390 !!--------------------------------------------------------------------- 391 TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields 392 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! nature of ptab_array grid-points 393 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! sign used across the north fold boundary 394 INTEGER , INTENT(in ) :: kfld ! number of 2D fields 395 ! 396 INTEGER :: jf !dummy loop index 397 !!--------------------------------------------------------------------- 398 ! 399 DO jf = 1, kfld 400 CALL lbc_lnk_2d( pt2d_array(jf)%pt2d, type_array(jf), psgn_array(jf) ) 401 END DO 402 ! 403 END SUBROUTINE lbc_lnk_2d_multiple 404 405 406 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC, & 407 & pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF, & 408 & pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, & 409 & cd_mpp, pval ) 410 !!--------------------------------------------------------------------- 411 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA ! 2D arrays on which the lbc is applied 412 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 413 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 414 CHARACTER(len=1) , INTENT(in ) :: cd_typeA ! nature of pt2D. array grid-points 415 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 416 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 417 REAL(wp) , INTENT(in ) :: psgnA ! sign used across the north fold 418 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 419 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 420 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 421 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 422 !! 423 !!--------------------------------------------------------------------- 424 ! 425 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) ! The first array 426 ! 427 IF( PRESENT (psgnB) ) CALL lbc_lnk( pt2dB, cd_typeB, psgnB ) ! Look if more arrays to process 428 IF( PRESENT (psgnC) ) CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 429 IF( PRESENT (psgnD) ) CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 430 IF( PRESENT (psgnE) ) CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 431 IF( PRESENT (psgnF) ) CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 432 IF( PRESENT (psgnG) ) CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 433 IF( PRESENT (psgnH) ) CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 434 IF( PRESENT (psgnI) ) CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 435 ! 436 END SUBROUTINE lbc_lnk_2d_9 437 438 239 !!====================================================================== 240 !! identical routines in both C1D and shared memory computing 241 !!====================================================================== 242 243 !!---------------------------------------------------------------------- 244 !! *** routine lbc_bdy_lnk_(2,3)d *** 245 !! 246 !! wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 247 !! to maintain the same interface with regards to the mpp case 248 !!---------------------------------------------------------------------- 249 439 250 SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 440 !!---------------------------------------------------------------------441 !! *** ROUTINE lbc_bdy_lnk ***442 !!443 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used444 !! to maintain the same interface with regards to the mpp case445 251 !!---------------------------------------------------------------------- 446 252 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied … … 449 255 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 450 256 !!---------------------------------------------------------------------- 451 !452 257 CALL lbc_lnk_3d( pt3d, cd_type, psgn) 453 !454 258 END SUBROUTINE lbc_bdy_lnk_3d 455 259 456 260 457 261 SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 458 !!---------------------------------------------------------------------459 !! *** ROUTINE lbc_bdy_lnk ***460 !!461 !! ** Purpose : wrapper rountine to 'lbc_lnk_2d'. This wrapper is used462 !! to maintain the same interface with regards to the mpp case463 262 !!---------------------------------------------------------------------- 464 263 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied … … 467 266 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 468 267 !!---------------------------------------------------------------------- 469 !470 268 CALL lbc_lnk_2d( pt2d, cd_type, psgn) 471 !472 269 END SUBROUTINE lbc_bdy_lnk_2d 473 270 474 271 272 !!gm This routine should be remove with an optional halos size added in orgument of generic routines 273 475 274 SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, ki, kj ) 476 !!---------------------------------------------------------------------477 !! *** ROUTINE lbc_lnk_2d ***478 !!479 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case)480 !! special dummy routine to allow for use of halo indexing in mpp case481 275 !!---------------------------------------------------------------------- 482 276 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied … … 485 279 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp) 486 280 !!---------------------------------------------------------------------- 487 !488 281 CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 489 !490 282 END SUBROUTINE lbc_lnk_2d_e 491 492 493 SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 494 !!--------------------------------------------------------------------- 495 !! *** ROUTINE lbc_lnk_sum_2d *** 496 !! 497 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case) 498 !! 499 !! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean 500 !! coupling if conservation option activated. As no ice shelf are present along 501 !! this line, nothing is done along the north fold. 502 !!---------------------------------------------------------------------- 503 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 504 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 505 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 506 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 507 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 508 !! 509 REAL(wp) :: zland 510 !!---------------------------------------------------------------------- 511 ! 512 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 513 ELSE ; zland = 0._wp 514 ENDIF 515 ! 516 IF (PRESENT(cd_mpp)) THEN 517 ! only fill the overlap area and extra allows 518 ! this is in mpp case. In this module, just do nothing 519 ELSE 520 ! ! East-West boundaries 521 ! ! ==================== 522 SELECT CASE ( nperio ) 523 ! 524 CASE ( 1 , 4 , 6 ) !** cyclic east-west 525 pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:) 526 pt2d( 2 ,:) = pt2d( 2 ,:) + pt2d(jpi,:) 527 pt2d( 1 ,:) = 0.0_wp ! all points 528 pt2d(jpi,:) = 0.0_wp 529 ! 530 CASE DEFAULT !** East closed -- West closed 531 SELECT CASE ( cd_type ) 532 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 533 pt2d( 1 ,:) = zland 534 pt2d(jpi,:) = zland 535 CASE ( 'F' ) ! F-point 536 pt2d(jpi,:) = zland 537 END SELECT 538 ! 539 END SELECT 540 ! ! North-South boundaries 541 ! ! ====================== 542 ! Nothing to do for the north fold, there is no ice shelf along this line. 543 ! 544 END IF 545 ! 546 END SUBROUTINE 547 548 549 SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 550 !!--------------------------------------------------------------------- 551 !! *** ROUTINE lbc_lnk_sum_3d *** 552 !! 553 !! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case) 554 !! 555 !! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean 556 !! coupling if conservation option activated. As no ice shelf are present along 557 !! this line, nothing is done along the north fold. 558 !!---------------------------------------------------------------------- 559 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 560 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 561 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 562 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 563 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 564 ! 565 REAL(wp) :: zland 566 !!---------------------------------------------------------------------- 567 ! 568 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 569 ELSE ; zland = 0._wp 570 ENDIF 571 ! 572 IF( PRESENT( cd_mpp ) ) THEN 573 ! only fill the overlap area and extra allows 574 ! this is in mpp case. In this module, just do nothing 575 ELSE 576 ! ! East-West boundaries 577 ! ! ====================== 578 SELECT CASE ( nperio ) 579 ! 580 CASE ( 1 , 4 , 6 ) !** cyclic east-west 581 pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 582 pt3d( 2 ,:,:) = pt3d( 2 ,:,:) + pt3d(jpi,:,:) 583 pt3d( 1 ,:,:) = 0._wp 584 pt3d(jpi,:,:) = 0._wp 585 ! 586 CASE DEFAULT !** East closed -- West closed 587 SELECT CASE ( cd_type ) 588 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 589 pt3d( 1 ,:,:) = zland 590 pt3d(jpi,:,:) = zland 591 CASE ( 'F' ) ! F-point 592 pt3d(jpi,:,:) = zland 593 END SELECT 594 ! 595 END SELECT 596 ! ! North-South boundaries 597 ! ! ====================== 598 ! Nothing to do for the north fold, there is no ice shelf along this line. 599 ! 600 END IF 601 ! 602 END SUBROUTINE 283 !!gm end 603 284 604 285 #endif 605 286 606 287 !!====================================================================== 288 !! identical routines in both distributed and shared memory computing 289 !!====================================================================== 290 291 !!---------------------------------------------------------------------- 292 !! *** load_ptr_(2,3,4)d *** 293 !! 294 !! * Dummy Argument : 295 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 296 !! cd_nat ! nature of pt2d array grid-points 297 !! psgn ! sign used across the north fold boundary 298 !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers 299 !! cdna_ptr ! nature of ptab array grid-points 300 !! psgn_ptr ! sign used across the north fold boundary 301 !! kfld ! number of elements that has been attributed 302 !!---------------------------------------------------------------------- 303 304 !!---------------------------------------------------------------------- 305 !! *** lbc_lnk_(2,3,4)d_multi *** 306 !! *** load_ptr_(2,3,4)d *** 307 !! 308 !! * Argument : dummy argument use in lbc_lnk_multi_... routines 309 !! 310 !!---------------------------------------------------------------------- 311 312 # define DIM_2d 313 # define ROUTINE_MULTI lbc_lnk_2d_multi 314 # define ROUTINE_LOAD load_ptr_2d 315 # include "lbc_lnk_multi_generic.h90" 316 # undef ROUTINE_MULTI 317 # undef ROUTINE_LOAD 318 # undef DIM_2d 319 320 321 # define DIM_3d 322 # define ROUTINE_MULTI lbc_lnk_3d_multi 323 # define ROUTINE_LOAD load_ptr_3d 324 # include "lbc_lnk_multi_generic.h90" 325 # undef ROUTINE_MULTI 326 # undef ROUTINE_LOAD 327 # undef DIM_3d 328 329 330 # define DIM_4d 331 # define ROUTINE_MULTI lbc_lnk_4d_multi 332 # define ROUTINE_LOAD load_ptr_4d 333 # include "lbc_lnk_multi_generic.h90" 334 # undef ROUTINE_MULTI 335 # undef ROUTINE_LOAD 336 # undef DIM_4d 337 338 !!====================================================================== 607 339 END MODULE lbclnk 608 340 -
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r8170 r8186 13 13 !! lbc_nfd_3d : lateral boundary condition: North fold treatment for a 3D arrays (lbc_nfd) 14 14 !! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd) 15 !! mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP16 !! mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP15 ! !! mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP 16 ! !! mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP 17 17 !!---------------------------------------------------------------------- 18 18 USE dom_oce ! ocean space and time domain … … 23 23 24 24 INTERFACE lbc_nfd 25 MODULE PROCEDURE lbc_nfd_3d, lbc_nfd_2d 25 MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d 26 MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 26 27 END INTERFACE 27 28 ! 28 INTERFACE mpp_lbc_nfd 29 MODULE PROCEDURE mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 30 END INTERFACE 29 !!gm INTERFACE mpp_lbc_nfd 30 !!gm MODULE PROCEDURE mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 31 !!gm END INTERFACE 32 33 TYPE, PUBLIC :: PTR_2D !: array of 2D pointers (also used in lib_mpp) 34 REAL(wp), DIMENSION (:,:) , POINTER :: pt2d 35 END TYPE PTR_2D 36 TYPE, PUBLIC :: PTR_3D !: array of 3D pointers (also used in lib_mpp) 37 REAL(wp), DIMENSION (:,:,:) , POINTER :: pt3d 38 END TYPE PTR_3D 39 TYPE, PUBLIC :: PTR_4D !: array of 4D pointers (also used in lib_mpp) 40 REAL(wp), DIMENSION (:,:,:,:), POINTER :: pt4d 41 END TYPE PTR_4D 31 42 32 43 PUBLIC lbc_nfd ! north fold conditions 33 PUBLIC mpp_lbc_nfd ! north fold conditions (parallel case)44 !!gm PUBLIC mpp_lbc_nfd ! north fold conditions (parallel case) 34 45 35 46 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !: … … 44 55 CONTAINS 45 56 46 SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn ) 47 !!---------------------------------------------------------------------- 48 !! *** routine lbc_nfd_3d *** 49 !! 50 !! ** Purpose : 3D lateral boundary condition : North fold treatment 51 !! without processor exchanges. 52 !! 53 !! ** Method : 54 !! 55 !! ** Action : pt3d with updated values along the north fold 56 !!---------------------------------------------------------------------- 57 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the boundary condition is applied 58 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-point 59 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 60 ! 61 INTEGER :: ji, jk 62 INTEGER :: ijt, iju, ijpj, ijpjm1 63 !!---------------------------------------------------------------------- 64 ! 65 SELECT CASE ( jpni ) 66 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 67 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 68 END SELECT 69 ijpjm1 = ijpj-1 70 71 DO jk = 1, SIZE( pt3d, 3 ) 72 ! 73 SELECT CASE ( npolj ) 74 ! 75 CASE ( 3 , 4 ) ! * North fold T-point pivot 76 ! 77 SELECT CASE ( cd_type ) 78 CASE ( 'T' , 'W' ) ! T-, W-point 79 DO ji = 2, jpiglo 80 ijt = jpiglo-ji+2 81 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 82 END DO 83 pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk) 84 DO ji = jpiglo/2+1, jpiglo 85 ijt = jpiglo-ji+2 86 pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 87 END DO 88 CASE ( 'U' ) ! U-point 89 DO ji = 1, jpiglo-1 90 iju = jpiglo-ji+1 91 pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) 92 END DO 93 pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-2,jk) 94 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk) 95 DO ji = jpiglo/2, jpiglo-1 96 iju = jpiglo-ji+1 97 pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 98 END DO 99 CASE ( 'V' ) ! V-point 100 DO ji = 2, jpiglo 101 ijt = jpiglo-ji+2 102 pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) 103 pt3d(ji,ijpj ,jk) = psgn * pt3d(ijt,ijpj-3,jk) 104 END DO 105 pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk) 106 CASE ( 'F' ) ! F-point 107 DO ji = 1, jpiglo-1 108 iju = jpiglo-ji+1 109 pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) 110 pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-3,jk) 111 END DO 112 pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-3,jk) 113 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk) 114 END SELECT 115 ! 116 CASE ( 5 , 6 ) ! * North fold F-point pivot 117 ! 118 SELECT CASE ( cd_type ) 119 CASE ( 'T' , 'W' ) ! T-, W-point 120 DO ji = 1, jpiglo 121 ijt = jpiglo-ji+1 122 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) 123 END DO 124 CASE ( 'U' ) ! U-point 125 DO ji = 1, jpiglo-1 126 iju = jpiglo-ji 127 pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) 128 END DO 129 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk) 130 CASE ( 'V' ) ! V-point 131 DO ji = 1, jpiglo 132 ijt = jpiglo-ji+1 133 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 134 END DO 135 DO ji = jpiglo/2+1, jpiglo 136 ijt = jpiglo-ji+1 137 pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 138 END DO 139 CASE ( 'F' ) ! F-point 140 DO ji = 1, jpiglo-1 141 iju = jpiglo-ji 142 pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-2,jk) 143 END DO 144 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk) 145 DO ji = jpiglo/2+1, jpiglo-1 146 iju = jpiglo-ji 147 pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 148 END DO 149 END SELECT 150 ! 151 CASE DEFAULT ! * closed : the code probably never go through 152 ! 153 SELECT CASE ( cd_type) 154 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 155 pt3d(:, 1 ,jk) = 0._wp 156 pt3d(:,ijpj,jk) = 0._wp 157 CASE ( 'F' ) ! F-point 158 pt3d(:,ijpj,jk) = 0._wp 159 END SELECT 160 ! 161 END SELECT ! npolj 162 ! 163 END DO 164 ! 165 END SUBROUTINE lbc_nfd_3d 166 167 168 SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj ) 57 !!---------------------------------------------------------------------- 58 !! *** routine lbc_nfd_(2,3,4)d *** 59 !!---------------------------------------------------------------------- 60 !! 61 !! ** Purpose : lateral boundary condition 62 !! North fold treatment without processor exchanges. 63 !! 64 !! ** Method : 65 !! 66 !! ** Action : ptab with updated values along the north fold 67 !!---------------------------------------------------------------------- 68 ! 69 ! !== 2D array and array of 2D pointer ==! 70 ! 71 # define DIM_2d 72 # define ROUTINE_NFD lbc_nfd_2d 73 # include "lbc_nfd_generic.h90" 74 # undef ROUTINE_NFD 75 # define MULTI 76 # define ROUTINE_NFD lbc_nfd_2d_ptr 77 # include "lbc_nfd_generic.h90" 78 # undef ROUTINE_NFD 79 # undef MULTI 80 # undef DIM_2d 81 ! 82 ! !== 3D array and array of 3D pointer ==! 83 ! 84 # define DIM_3d 85 # define ROUTINE_NFD lbc_nfd_3d 86 # include "lbc_nfd_generic.h90" 87 # undef ROUTINE_NFD 88 # define MULTI 89 # define ROUTINE_NFD lbc_nfd_3d_ptr 90 # include "lbc_nfd_generic.h90" 91 # undef ROUTINE_NFD 92 # undef MULTI 93 # undef DIM_3d 94 ! 95 ! !== 4D array and array of 4D pointer ==! 96 ! 97 # define DIM_4d 98 # define ROUTINE_NFD lbc_nfd_4d 99 # include "lbc_nfd_generic.h90" 100 # undef ROUTINE_NFD 101 # define MULTI 102 # define ROUTINE_NFD lbc_nfd_4d_ptr 103 # include "lbc_nfd_generic.h90" 104 # undef ROUTINE_NFD 105 # undef MULTI 106 # undef DIM_4d 107 108 !!---------------------------------------------------------------------- 109 110 111 !!gm CAUTION HERE optional pr2dj not implemented in generic case 112 !!gm furthermore, in the _org routine it is OK only for T-point pivot !! 113 114 115 SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj ) 169 116 !!---------------------------------------------------------------------- 170 117 !! *** routine lbc_nfd_2d *** … … 178 125 !!---------------------------------------------------------------------- 179 126 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 180 CHARACTER(len=1) , INTENT(in ) :: cd_ type! nature of pt2d grid-point127 CHARACTER(len=1) , INTENT(in ) :: cd_nat ! nature of pt2d grid-point 181 128 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 182 129 INTEGER , OPTIONAL , INTENT(in ) :: pr2dj ! number of additional halos … … 205 152 CASE ( 3, 4 ) ! * North fold T-point pivot 206 153 ! 207 SELECT CASE ( cd_ type)154 SELECT CASE ( cd_nat ) 208 155 ! 209 156 CASE ( 'T' , 'W' ) ! T- , W-points … … 264 211 CASE ( 5, 6 ) ! * North fold F-point pivot 265 212 ! 266 SELECT CASE ( cd_ type)213 SELECT CASE ( cd_nat ) 267 214 CASE ( 'T' , 'W' ) ! T-, W-point 268 215 DO jl = 0, ipr2dj … … 315 262 CASE DEFAULT ! * closed : the code probably never go through 316 263 ! 317 SELECT CASE ( cd_ type)264 SELECT CASE ( cd_nat) 318 265 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 319 266 pt2d(:, 1:1-ipr2dj ) = 0._wp … … 328 275 END SELECT 329 276 ! 330 END SUBROUTINE lbc_nfd_2d 331 332 333 SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 334 !!---------------------------------------------------------------------- 335 !! *** routine mpp_lbc_nfd_3d *** 336 !! 337 !! ** Purpose : 3D lateral boundary condition : North fold treatment 338 !! without processor exchanges. 339 !! 340 !! ** Method : 341 !! 342 !! ** Action : pt3d with updated values along the north fold 343 !!---------------------------------------------------------------------- 344 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3dl ! 3D array on which the boundary condition is applied 345 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pt3dr ! 3D array on which the boundary condition is applied 346 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d(l/r) grid-point 347 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 348 ! 349 INTEGER :: ji, jk ! dummy loop indices 350 INTEGER :: ipk ! 3rd dimension of the input array 351 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 352 !!---------------------------------------------------------------------- 353 ! 354 ipk = SIZE( pt3dl, 3 ) 355 ! 356 SELECT CASE ( jpni ) 357 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 358 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 359 END SELECT 360 ijpjm1 = ijpj-1 361 ! 362 ! 363 SELECT CASE ( npolj ) 364 ! 365 CASE ( 3 , 4 ) ! * North fold T-point pivot 366 ! 367 SELECT CASE ( cd_type ) 368 CASE ( 'T' , 'W' ) ! T-, W-point 369 IF ( nimpp /= 1 ) THEN ; startloop = 1 370 ELSE ; startloop = 2 371 ENDIF 372 ! 373 DO jk = 1, ipk 374 DO ji = startloop, nlci 375 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 376 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 377 END DO 378 IF(nimpp .eq. 1) THEN 379 pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk) 380 ENDIF 381 END DO 382 383 IF( nimpp >= jpiglo/2+1 ) THEN 384 startloop = 1 385 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 386 startloop = jpiglo/2+1 - nimpp + 1 387 ELSE 388 startloop = nlci + 1 389 ENDIF 390 IF(startloop <= nlci) THEN 391 DO jk = 1, ipk 392 DO ji = startloop, nlci 393 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 394 jia = ji + nimpp - 1 395 ijta = jpiglo - jia + 2 396 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 397 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 398 ELSE 399 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 400 ENDIF 401 END DO 402 END DO 403 ENDIF 404 ! 405 CASE ( 'U' ) ! U-point 406 IF( nimpp + nlci - 1 /= jpiglo ) THEN 407 endloop = nlci 408 ELSE 409 endloop = nlci - 1 410 ENDIF 411 DO jk = 1, ipk 412 DO ji = 1, endloop 413 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 414 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 415 END DO 416 IF(nimpp .eq. 1) THEN 417 pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-2,jk) 418 ENDIF 419 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 420 pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk) 421 ENDIF 422 END DO 423 ! 424 IF( nimpp + nlci - 1 /= jpiglo ) THEN 425 endloop = nlci 426 ELSE 427 endloop = nlci - 1 428 ENDIF 429 IF( nimpp >= jpiglo/2 ) THEN 430 startloop = 1 431 ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 432 startloop = jpiglo/2 - nimpp + 1 433 ELSE 434 startloop = endloop + 1 435 ENDIF 436 IF( startloop <= endloop ) THEN 437 DO jk = 1, ipk 438 DO ji = startloop, endloop 439 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 440 jia = ji + nimpp - 1 441 ijua = jpiglo - jia + 1 442 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 443 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 444 ELSE 445 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 446 ENDIF 447 END DO 448 END DO 449 ENDIF 450 ! 451 CASE ( 'V' ) ! V-point 452 IF( nimpp /= 1 ) THEN 453 startloop = 1 454 ELSE 455 startloop = 2 456 ENDIF 457 DO jk = 1, ipk 458 DO ji = startloop, nlci 459 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 460 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 461 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 462 END DO 463 IF(nimpp .eq. 1) THEN 464 pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk) 465 ENDIF 466 END DO 467 CASE ( 'F' ) ! F-point 468 IF( nimpp + nlci - 1 /= jpiglo ) THEN 469 endloop = nlci 470 ELSE 471 endloop = nlci - 1 472 ENDIF 473 DO jk = 1, ipk 474 DO ji = 1, endloop 475 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 476 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 477 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 478 END DO 479 IF(nimpp .eq. 1) THEN 480 pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-3,jk) 481 ENDIF 482 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 483 pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk) 484 ENDIF 485 END DO 486 END SELECT 487 ! 488 CASE ( 5 , 6 ) ! * North fold F-point pivot 489 ! 490 SELECT CASE ( cd_type ) 491 CASE ( 'T' , 'W' ) ! T-, W-point 492 DO jk = 1, ipk 493 DO ji = 1, nlci 494 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 495 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 496 END DO 497 END DO 498 ! 499 CASE ( 'U' ) ! U-point 500 IF( nimpp + nlci - 1 /= jpiglo ) THEN 501 endloop = nlci 502 ELSE 503 endloop = nlci - 1 504 ENDIF 505 DO jk = 1, ipk 506 DO ji = 1, endloop 507 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 508 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 509 END DO 510 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 511 pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk) 512 ENDIF 513 END DO 514 ! 515 CASE ( 'V' ) ! V-point 516 DO jk = 1, ipk 517 DO ji = 1, nlci 518 ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 519 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 520 END DO 521 END DO 522 ! 523 IF( nimpp >= jpiglo/2+1 ) THEN 524 startloop = 1 525 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 526 startloop = jpiglo/2+1 - nimpp + 1 527 ELSE 528 startloop = nlci + 1 529 ENDIF 530 IF( startloop <= nlci ) THEN 531 DO jk = 1, ipk 532 DO ji = startloop, nlci 533 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 534 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 535 END DO 536 END DO 537 ENDIF 538 ! 539 CASE ( 'F' ) ! F-point 540 IF( nimpp + nlci - 1 /= jpiglo ) THEN 541 endloop = nlci 542 ELSE 543 endloop = nlci - 1 544 ENDIF 545 DO jk = 1, ipk 546 DO ji = 1, endloop 547 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 548 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 549 END DO 550 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 551 pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk) 552 ENDIF 553 END DO 554 ! 555 IF( nimpp + nlci - 1 /= jpiglo ) THEN 556 endloop = nlci 557 ELSE 558 endloop = nlci - 1 559 ENDIF 560 IF( nimpp >= jpiglo/2+1 ) THEN 561 startloop = 1 562 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 563 startloop = jpiglo/2+1 - nimpp + 1 564 ELSE 565 startloop = endloop + 1 566 ENDIF 567 IF( startloop <= endloop ) THEN 568 DO jk = 1, ipk 569 DO ji = startloop, endloop 570 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 571 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 572 END DO 573 END DO 574 ENDIF 575 ! 576 END SELECT 577 ! 578 CASE DEFAULT ! * closed : the code probably never go through 579 ! 580 SELECT CASE ( cd_type) 581 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 582 pt3dl(:, 1 ,jk) = 0._wp 583 pt3dl(:,ijpj,jk) = 0._wp 584 CASE ( 'F' ) ! F-point 585 pt3dl(:,ijpj,jk) = 0._wp 586 END SELECT 587 ! 588 END SELECT ! npolj 589 ! 590 END SUBROUTINE mpp_lbc_nfd_3d 591 592 593 SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 594 !!---------------------------------------------------------------------- 595 !! *** routine mpp_lbc_nfd_2d *** 596 !! 597 !! ** Purpose : 2D lateral boundary condition : North fold treatment 598 !! without processor exchanges. 599 !! 600 !! ** Method : 601 !! 602 !! ** Action : pt2dl with updated values along the north fold 603 !!---------------------------------------------------------------------- 604 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2dl ! 2D array on which the boundary condition is applied 605 REAL(wp), DIMENSION(:,:), INTENT(in ) :: pt2dr ! 2D array on which the boundary condition is applied 606 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d(l/r) grid-point 607 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 608 ! 609 INTEGER :: ji 610 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 611 !!---------------------------------------------------------------------- 612 613 SELECT CASE ( jpni ) 614 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 615 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 616 END SELECT 617 ! 618 ijpjm1 = ijpj-1 619 ! 620 ! 621 SELECT CASE ( npolj ) 622 ! 623 CASE ( 3, 4 ) ! * North fold T-point pivot 624 ! 625 SELECT CASE ( cd_type ) 626 ! 627 CASE ( 'T' , 'W' ) ! T- , W-points 628 IF( nimpp /= 1 ) THEN 629 startloop = 1 630 ELSE 631 startloop = 2 632 ENDIF 633 DO ji = startloop, nlci 634 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 635 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 636 END DO 637 IF( nimpp == 1 ) THEN 638 pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2) 639 ENDIF 640 ! 641 IF( nimpp >= jpiglo/2+1 ) THEN 642 startloop = 1 643 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 644 startloop = jpiglo/2+1 - nimpp + 1 645 ELSE 646 startloop = nlci + 1 647 ENDIF 648 DO ji = startloop, nlci 649 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 650 jia = ji + nimpp - 1 651 ijta = jpiglo - jia + 2 652 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 653 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 654 ELSE 655 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 656 ENDIF 657 END DO 658 ! 659 CASE ( 'U' ) ! U-point 660 IF( nimpp + nlci - 1 /= jpiglo ) THEN 661 endloop = nlci 662 ELSE 663 endloop = nlci - 1 664 ENDIF 665 DO ji = 1, endloop 666 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 667 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 668 END DO 669 ! 670 IF (nimpp .eq. 1) THEN 671 pt2dl( 1 ,ijpj ) = psgn * pt2dl( 2 ,ijpj-2) 672 pt2dl(1 ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1) 673 ENDIF 674 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 675 pt2dl(nlci,ijpj ) = psgn * pt2dl(nlci-1,ijpj-2) 676 ENDIF 677 ! 678 IF( nimpp + nlci - 1 /= jpiglo ) THEN 679 endloop = nlci 680 ELSE 681 endloop = nlci - 1 682 ENDIF 683 IF( nimpp >= jpiglo/2 ) THEN 684 startloop = 1 685 ELSEIF( nimpp+nlci-1 >= jpiglo/2 .AND. nimpp < jpiglo/2 ) THEN 686 startloop = jpiglo/2 - nimpp + 1 687 ELSE 688 startloop = endloop + 1 689 ENDIF 690 DO ji = startloop, endloop 691 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 692 jia = ji + nimpp - 1 693 ijua = jpiglo - jia + 1 694 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 695 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 696 ELSE 697 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 698 ENDIF 699 END DO 700 ! 701 CASE ( 'V' ) ! V-point 702 IF( nimpp /= 1 ) THEN 703 startloop = 1 704 ELSE 705 startloop = 2 706 ENDIF 707 DO ji = startloop, nlci 708 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 709 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 710 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 711 END DO 712 IF (nimpp .eq. 1) THEN 713 pt2dl( 1 ,ijpj) = psgn * pt2dl( 3 ,ijpj-3) 714 ENDIF 715 ! 716 CASE ( 'F' ) ! F-point 717 IF( nimpp + nlci - 1 /= jpiglo ) THEN 718 endloop = nlci 719 ELSE 720 endloop = nlci - 1 721 ENDIF 722 DO ji = 1, endloop 723 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 724 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 725 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 726 END DO 727 IF (nimpp .eq. 1) THEN 728 pt2dl( 1 ,ijpj) = psgn * pt2dl( 2 ,ijpj-3) 729 pt2dl( 1 ,ijpj-1) = psgn * pt2dl( 2 ,ijpj-2) 730 ENDIF 731 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 732 pt2dl(nlci,ijpj) = psgn * pt2dl(nlci-1,ijpj-3) 733 pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2) 734 ENDIF 735 ! 736 CASE ( 'I' ) ! ice U-V point (I-point) 737 IF( nimpp /= 1 ) THEN 738 startloop = 1 739 ELSE 740 startloop = 3 741 pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 742 ENDIF 743 DO ji = startloop, nlci 744 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 745 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 746 END DO 747 ! 748 END SELECT 749 ! 750 CASE ( 5, 6 ) ! * North fold F-point pivot 751 ! 752 SELECT CASE ( cd_type ) 753 CASE ( 'T' , 'W' ) ! T-, W-point 754 DO ji = 1, nlci 755 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 756 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 757 END DO 758 ! 759 CASE ( 'U' ) ! U-point 760 IF( nimpp + nlci - 1 /= jpiglo ) THEN 761 endloop = nlci 762 ELSE 763 endloop = nlci - 1 764 ENDIF 765 DO ji = 1, endloop 766 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 767 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 768 END DO 769 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 770 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 771 ENDIF 772 ! 773 CASE ( 'V' ) ! V-point 774 DO ji = 1, nlci 775 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 776 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 777 END DO 778 IF( nimpp >= jpiglo/2+1 ) THEN 779 startloop = 1 780 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 781 startloop = jpiglo/2+1 - nimpp + 1 782 ELSE 783 startloop = nlci + 1 784 ENDIF 785 DO ji = startloop, nlci 786 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 787 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 788 END DO 789 ! 790 CASE ( 'F' ) ! F-point 791 IF( nimpp + nlci - 1 /= jpiglo ) THEN 792 endloop = nlci 793 ELSE 794 endloop = nlci - 1 795 ENDIF 796 DO ji = 1, endloop 797 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 798 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 799 END DO 800 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 801 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 802 ENDIF 803 ! 804 IF( nimpp + nlci - 1 /= jpiglo ) THEN 805 endloop = nlci 806 ELSE 807 endloop = nlci - 1 808 ENDIF 809 IF( nimpp >= jpiglo/2+1 ) THEN 810 startloop = 1 811 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 812 startloop = jpiglo/2+1 - nimpp + 1 813 ELSE 814 startloop = endloop + 1 815 ENDIF 816 ! 817 DO ji = startloop, endloop 818 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 819 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 820 END DO 821 ! 822 CASE ( 'I' ) ! ice U-V point (I-point) 823 IF( nimpp /= 1 ) THEN 824 startloop = 1 825 ELSE 826 startloop = 2 827 ENDIF 828 IF( nimpp + nlci - 1 /= jpiglo ) THEN 829 endloop = nlci 830 ELSE 831 endloop = nlci - 1 832 ENDIF 833 DO ji = startloop , endloop 834 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 835 pt2dl(ji,ijpj) = 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 836 END DO 837 ! 838 END SELECT 839 ! 840 CASE DEFAULT ! * closed : the code probably never go through 841 ! 842 SELECT CASE ( cd_type) 843 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 844 pt2dl(:, 1 ) = 0._wp 845 pt2dl(:,ijpj) = 0._wp 846 CASE ( 'F' ) ! F-point 847 pt2dl(:,ijpj) = 0._wp 848 CASE ( 'I' ) ! ice U-V point 849 pt2dl(:, 1 ) = 0._wp 850 pt2dl(:,ijpj) = 0._wp 851 END SELECT 852 ! 853 END SELECT 854 ! 855 END SUBROUTINE mpp_lbc_nfd_2d 277 END SUBROUTINE lbc_nfd_2d_org 856 278 857 279 !!====================================================================== -
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r8170 r8186 19 19 !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl 20 20 !! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager 21 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d', 22 !! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 23 !! the mppobc routine to optimize the BDY and OBC communications 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 21 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm. 22 !! 3.5 ! 2013 (C. Ethe, G. Madec) message passing arrays as local variables 25 23 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 24 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max 27 25 !! 4.0 ! 2017 (G. Madec) automatique allocation of array argument (use any 3rd dimension) 26 !! - ! 2017 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 28 27 !!---------------------------------------------------------------------- 29 28 … … 42 41 !! mynode : indentify the processor unit 43 42 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 44 !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays45 43 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 46 44 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) … … 57 55 !! mppstop : 58 56 !! mpp_ini_north : initialisation of north fold 59 !! mpp_lbc_north : north fold processors gathering57 !!gm !! mpp_lbc_north : north fold processors gathering 60 58 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 61 59 !! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs … … 68 66 IMPLICIT NONE 69 67 PRIVATE 70 68 69 INTERFACE mpp_nfd 70 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 71 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 72 END INTERFACE 73 74 ! Interface associated to the mpp_lnk_... routines is defined in lbclnk 75 PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 76 PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 77 PUBLIC mpp_lnk_2d_e 78 ! 79 !!gm this should be useless 80 PUBLIC mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 81 PUBLIC mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 82 !!gm end 83 ! 71 84 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 72 85 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 73 PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 86 PUBLIC mpp_ini_north, mpp_lbc_north_e 87 !!gm PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 88 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 74 89 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 75 90 PUBLIC mpp_max_multiple 76 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 77 PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple 78 PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 91 !!gm PUBLIC mpp_lnk_2d_9 92 !!gm PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 79 93 PUBLIC mppscatter, mppgather 80 94 PUBLIC mpp_ini_ice, mpp_ini_znl … … 82 96 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 83 97 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 84 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb85 98 PUBLIC mpprank 86 87 TYPE arrayptr88 REAL(wp), DIMENSION (:,:), POINTER :: pt2d89 END TYPE arrayptr90 !91 PUBLIC arrayptr92 99 93 100 !! * Interfaces … … 105 112 & mppsum_realdd, mppsum_a_realdd 106 113 END INTERFACE 107 INTERFACE mpp_lbc_north108 MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d109 END INTERFACE114 !!gm INTERFACE mpp_lbc_north 115 !!gm MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 116 !!gm END INTERFACE 110 117 INTERFACE mpp_minloc 111 118 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d … … 327 334 END FUNCTION mynode 328 335 329 330 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 331 !!---------------------------------------------------------------------- 332 !! *** routine mpp_lnk_3d *** 333 !! 334 !! ** Purpose : Message passing manadgement 335 !! 336 !! ** Method : Use mppsend and mpprecv function for passing mask 337 !! between processors following neighboring subdomains. 338 !! domain parameters 339 !! nlci : first dimension of the local subdomain 340 !! nlcj : second dimension of the local subdomain 341 !! nbondi : mark for "east-west local boundary" 342 !! nbondj : mark for "north-south local boundary" 343 !! noea : number for local neighboring processors 344 !! nowe : number for local neighboring processors 345 !! noso : number for local neighboring processors 346 !! nono : number for local neighboring processors 347 !! 348 !! ** Action : ptab with update value at its periphery 349 !!---------------------------------------------------------------------- 350 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 351 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 352 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 353 CHARACTER(len=3), OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 354 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 355 ! 356 INTEGER :: ji, jj, jk, jl ! dummy loop indices 357 INTEGER :: ipk ! 3rd dimension of the input array 358 INTEGER :: imigr, iihom, ijhom ! temporary integers 359 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 360 REAL(wp) :: zland 361 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 362 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 363 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 364 !!---------------------------------------------------------------------- 365 ! 366 ipk = SIZE( ptab, 3 ) 367 ! 368 ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2), & 369 & zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2) ) 370 371 ! 372 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 373 ELSE ; zland = 0._wp ! zero by default 374 ENDIF 375 376 ! 1. standard boundary treatment 377 ! ------------------------------ 378 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 379 ! 380 ! WARNING ptab is defined only between nld and nle 381 DO jk = 1, ipk 382 DO jj = nlcj+1, jpj ! added line(s) (inner only) 383 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 384 ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) 385 ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) 386 END DO 387 DO ji = nlci+1, jpi ! added column(s) (full) 388 ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk) 389 ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk) 390 ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk) 391 END DO 392 END DO 393 ! 394 ELSE ! standard close or cyclic treatment 395 ! 396 ! ! East-West boundaries 397 ! !* Cyclic 398 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 399 ptab( 1 ,:,:) = ptab(jpim1,:,:) 400 ptab(jpi,:,:) = ptab( 2 ,:,:) 401 ELSE !* closed 402 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 403 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 404 ENDIF 405 ! ! North-South boundaries 406 ! !* cyclic (only with no mpp j-split) 407 IF( nbondj == 2 .AND. jperio == 7 ) THEN 408 ptab(:,1 , :) = ptab(:, jpjm1,:) 409 ptab(:,jpj,:) = ptab(:, 2,:) 410 ELSE !* closed 411 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 412 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 413 ENDIF 414 ! 415 ENDIF 416 417 ! 2. East and west directions exchange 418 ! ------------------------------------ 419 ! we play with the neigbours AND the row number because of the periodicity 420 ! 421 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 422 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 423 iihom = nlci-nreci 424 DO jl = 1, jpreci 425 zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 426 zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 427 END DO 428 END SELECT 429 ! 430 ! ! Migrations 431 imigr = jpreci * jpj * ipk 432 ! 433 SELECT CASE ( nbondi ) 434 CASE ( -1 ) 435 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 436 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 437 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 438 CASE ( 0 ) 439 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 440 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 441 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 442 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 443 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 444 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 445 CASE ( 1 ) 446 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 447 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 448 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 449 END SELECT 450 ! 451 ! ! Write Dirichlet lateral conditions 452 iihom = nlci-jpreci 453 ! 454 SELECT CASE ( nbondi ) 455 CASE ( -1 ) 456 DO jl = 1, jpreci 457 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 458 END DO 459 CASE ( 0 ) 460 DO jl = 1, jpreci 461 ptab(jl ,:,:) = zt3we(:,jl,:,2) 462 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 463 END DO 464 CASE ( 1 ) 465 DO jl = 1, jpreci 466 ptab(jl ,:,:) = zt3we(:,jl,:,2) 467 END DO 468 END SELECT 469 470 ! 3. North and south directions 471 ! ----------------------------- 472 ! always closed : we play only with the neigbours 473 ! 474 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 475 ijhom = nlcj-nrecj 476 DO jl = 1, jprecj 477 zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 478 zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 479 END DO 480 ENDIF 481 ! 482 ! ! Migrations 483 imigr = jprecj * jpi * ipk 484 ! 485 SELECT CASE ( nbondj ) 486 CASE ( -1 ) 487 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 488 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 489 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 490 CASE ( 0 ) 491 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 492 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 493 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 494 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 495 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 496 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 497 CASE ( 1 ) 498 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 499 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 500 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 501 END SELECT 502 ! 503 ! ! Write Dirichlet lateral conditions 504 ijhom = nlcj-jprecj 505 ! 506 SELECT CASE ( nbondj ) 507 CASE ( -1 ) 508 DO jl = 1, jprecj 509 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 510 END DO 511 CASE ( 0 ) 512 DO jl = 1, jprecj 513 ptab(:,jl ,:) = zt3sn(:,jl,:,2) 514 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 515 END DO 516 CASE ( 1 ) 517 DO jl = 1, jprecj 518 ptab(:,jl,:) = zt3sn(:,jl,:,2) 519 END DO 520 END SELECT 521 522 ! 4. north fold treatment 523 ! ----------------------- 524 ! 525 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 526 ! 527 SELECT CASE ( jpni ) 528 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 529 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 530 END SELECT 531 ! 532 ENDIF 533 ! 534 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 535 ! 536 END SUBROUTINE mpp_lnk_3d 537 538 539 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp, pval ) 540 !!---------------------------------------------------------------------- 541 !! *** routine mpp_lnk_2d_multiple *** 542 !! 543 !! ** Purpose : Message passing management for multiple 2d arrays 544 !! 545 !! ** Method : Use mppsend and mpprecv function for passing mask 546 !! between processors following neighboring subdomains. 547 !! domain parameters 548 !! nlci : first dimension of the local subdomain 549 !! nlcj : second dimension of the local subdomain 550 !! nbondi : mark for "east-west local boundary" 551 !! nbondj : mark for "north-south local boundary" 552 !! noea : number for local neighboring processors 553 !! nowe : number for local neighboring processors 554 !! noso : number for local neighboring processors 555 !! nono : number for local neighboring processors 556 !!---------------------------------------------------------------------- 557 TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields 558 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! nature of pt2d_array grid-points 559 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! sign used across the north fold boundary 560 INTEGER , INTENT(in ) :: kfld ! number of pt2d arrays 561 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 562 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 563 ! 564 INTEGER :: ji, jj, jl, jf ! dummy loop indices 565 INTEGER :: imigr, iihom, ijhom ! temporary integers 566 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 567 REAL(wp) :: zland 568 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 569 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 570 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 571 !!---------------------------------------------------------------------- 572 ! 573 ALLOCATE( zt2ns(jpi,jprecj,2*kfld), zt2sn(jpi,jprecj,2*kfld), & 574 & zt2ew(jpj,jpreci,2*kfld), zt2we(jpj,jpreci,2*kfld) ) 575 ! 576 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 577 ELSE ; zland = 0._wp ! zero by default 578 ENDIF 579 580 ! 1. standard boundary treatment 581 ! ------------------------------ 582 ! 583 !First Array 584 DO jf = 1 , kfld 585 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 586 ! 587 ! WARNING pt2d is defined only between nld and nle 588 DO jj = nlcj+1, jpj ! added line(s) (inner only) 589 pt2d_array(jf)%pt2d(nldi :nlei , jj) = pt2d_array(jf)%pt2d(nldi:nlei, nlej) 590 pt2d_array(jf)%pt2d(1 :nldi-1, jj) = pt2d_array(jf)%pt2d(nldi , nlej) 591 pt2d_array(jf)%pt2d(nlei+1:nlci , jj) = pt2d_array(jf)%pt2d( nlei, nlej) 592 END DO 593 DO ji = nlci+1, jpi ! added column(s) (full) 594 pt2d_array(jf)%pt2d(ji, nldj :nlej ) = pt2d_array(jf)%pt2d(nlei, nldj:nlej) 595 pt2d_array(jf)%pt2d(ji, 1 :nldj-1) = pt2d_array(jf)%pt2d(nlei, nldj ) 596 pt2d_array(jf)%pt2d(ji, nlej+1:jpj ) = pt2d_array(jf)%pt2d(nlei, nlej) 597 END DO 598 ! 599 ELSE ! standard close or cyclic treatment 600 ! 601 ! ! East-West boundaries 602 IF( nbondi == 2 .AND. & !* Cyclic 603 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 604 pt2d_array(jf)%pt2d( 1 , : ) = pt2d_array(jf)%pt2d( jpim1, : ) ! west 605 pt2d_array(jf)%pt2d( jpi , : ) = pt2d_array(jf)%pt2d( 2 , : ) ! east 606 ELSE !* Closed 607 IF( .NOT. type_array(jf) == 'F' ) pt2d_array(jf)%pt2d( 1 : jpreci,:) = zland ! south except F-point 608 pt2d_array(jf)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north 609 ENDIF 610 ! ! North-South boundaries 611 ! !* Cyclic 612 IF( nbondj == 2 .AND. jperio == 7 ) THEN 613 pt2d_array(jf)%pt2d(:, 1 ) = pt2d_array(jf)%pt2d(:, jpjm1 ) 614 pt2d_array(jf)%pt2d(:, jpj ) = pt2d_array(jf)%pt2d(:, 2 ) 615 ELSE !* Closed 616 IF( .NOT. type_array(jf) == 'F' ) pt2d_array(jf)%pt2d(:, 1:jprecj ) = zland ! south except F-point 617 pt2d_array(jf)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north 618 ENDIF 619 ENDIF 620 END DO 621 622 ! 2. East and west directions exchange 623 ! ------------------------------------ 624 ! we play with the neigbours AND the row number because of the periodicity 625 ! 626 DO jf = 1 , kfld 627 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 628 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 629 iihom = nlci-nreci 630 DO jl = 1, jpreci 631 zt2ew( : , jl , jf ) = pt2d_array(jf)%pt2d( jpreci+jl , : ) 632 zt2we( : , jl , jf ) = pt2d_array(jf)%pt2d( iihom +jl , : ) 633 END DO 634 END SELECT 635 END DO 636 ! 637 ! ! Migrations 638 imigr = jpreci * jpj 639 ! 640 SELECT CASE ( nbondi ) 641 CASE ( -1 ) 642 CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req1 ) 643 CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea ) 644 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 645 CASE ( 0 ) 646 CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 ) 647 CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req2 ) 648 CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea ) 649 CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe ) 650 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 651 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 652 CASE ( 1 ) 653 CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 ) 654 CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe ) 655 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 656 END SELECT 657 ! 658 ! ! Write Dirichlet lateral conditions 659 iihom = nlci - jpreci 660 ! 661 662 DO jf = 1 , kfld 663 SELECT CASE ( nbondi ) 664 CASE ( -1 ) 665 DO jl = 1, jpreci 666 pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf) 667 END DO 668 CASE ( 0 ) 669 DO jl = 1, jpreci 670 pt2d_array(jf)%pt2d( jl ,:) = zt2we(:,jl,kfld+jf) 671 pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf) 672 END DO 673 CASE ( 1 ) 674 DO jl = 1, jpreci 675 pt2d_array(jf)%pt2d( jl ,:)= zt2we(:,jl,kfld+jf) 676 END DO 677 END SELECT 678 END DO 679 680 ! 3. North and south directions 681 ! ----------------------------- 682 ! always closed : we play only with the neigbours 683 ! 684 !First Array 685 DO jf = 1 , kfld 686 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 687 ijhom = nlcj-nrecj 688 DO jl = 1, jprecj 689 zt2sn(:,jl,jf) = pt2d_array(jf)%pt2d(:, ijhom +jl ) 690 zt2ns(:,jl,jf) = pt2d_array(jf)%pt2d(:, jprecj+jl ) 691 END DO 692 ENDIF 693 END DO 694 ! 695 ! ! Migrations 696 imigr = jprecj * jpi 697 ! 698 SELECT CASE ( nbondj ) 699 CASE ( -1 ) 700 CALL mppsend( 4, zt2sn(1,1, 1), kfld*imigr, nono, ml_req1 ) 701 CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono ) 702 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 703 CASE ( 0 ) 704 CALL mppsend( 3, zt2ns(1,1, 1), kfld*imigr, noso, ml_req1 ) 705 CALL mppsend( 4, zt2sn(1,1, 1), kfld*imigr, nono, ml_req2 ) 706 CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono ) 707 CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso ) 708 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 709 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 710 CASE ( 1 ) 711 CALL mppsend( 3, zt2ns(1,1, 1), kfld*imigr, noso, ml_req1 ) 712 CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso ) 713 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 714 END SELECT 715 ! 716 ! ! Write Dirichlet lateral conditions 717 ijhom = nlcj - jprecj 718 ! 719 DO jf = 1 , kfld 720 SELECT CASE ( nbondj ) 721 CASE ( -1 ) 722 DO jl = 1, jprecj 723 pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf ) 724 END DO 725 CASE ( 0 ) 726 DO jl = 1, jprecj 727 pt2d_array(jf)%pt2d(:, jl ) = zt2sn(:,jl, kfld+jf ) 728 pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf ) 729 END DO 730 CASE ( 1 ) 731 DO jl = 1, jprecj 732 pt2d_array(jf)%pt2d(:, jl ) = zt2sn(:,jl, kfld+jf ) 733 END DO 734 END SELECT 735 END DO 736 737 ! 4. north fold treatment 738 ! ----------------------- 739 ! 740 IF( npolj /= 0 .AND. .NOT.PRESENT(cd_mpp) ) THEN 741 ! 742 SELECT CASE ( jpni ) 743 CASE ( 1 ) 744 DO jf = 1, kfld 745 CALL lbc_nfd( pt2d_array(jf)%pt2d(:,:), type_array(jf), psgn_array(jf) ) ! only 1 northern proc, no mpp 746 END DO 747 CASE DEFAULT 748 CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, kfld ) ! for all northern procs. 749 END SELECT 750 ! 751 ENDIF 752 ! 753 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 754 ! 755 END SUBROUTINE mpp_lnk_2d_multiple 756 757 758 SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, kfld ) 759 !!--------------------------------------------------------------------- 760 REAL(wp) , DIMENSION(:,:), TARGET, INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 761 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points 762 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 763 TYPE(arrayptr) , DIMENSION(:) , INTENT(inout) :: pt2d_array ! 764 CHARACTER(len=1), DIMENSION(:) , INTENT(inout) :: type_array ! nature of pt2d_array array grid-points 765 REAL(wp) , DIMENSION(:) , INTENT(inout) :: psgn_array ! sign used across the north fold boundary 766 INTEGER , INTENT(inout) :: kfld ! 767 !!--------------------------------------------------------------------- 768 ! 769 kfld = kfld + 1 770 pt2d_array(kfld)%pt2d => pt2d 771 type_array(kfld) = cd_type 772 psgn_array(kfld) = psgn 773 ! 774 END SUBROUTINE load_array 336 !!---------------------------------------------------------------------- 337 !! *** routine mpp_lnk_(2,3,4)d *** 338 !! 339 !! * Argument : dummy argument use in mpp_lnk_... routines 340 !! ptab : array or pointer of arrays on which the boundary condition is applied 341 !! cd_nat : nature of array grid-points 342 !! psgn : sign used across the north fold boundary 343 !! kfld : optional, number of pt3d arrays 344 !! cd_mpp : optional, fill the overlap area only 345 !! pval : optional, background value (used at closed boundaries) 346 !!---------------------------------------------------------------------- 347 ! 348 ! !== 2D array and array of 2D pointer ==! 349 ! 350 # define DIM_2d 351 # define ROUTINE_LNK mpp_lnk_2d 352 # include "mpp_lnk_generic.h90" 353 # undef ROUTINE_LNK 354 # define MULTI 355 # define ROUTINE_LNK mpp_lnk_2d_ptr 356 # include "mpp_lnk_generic.h90" 357 # undef ROUTINE_LNK 358 # undef MULTI 359 # undef DIM_2d 360 ! 361 ! !== 3D array and array of 3D pointer ==! 362 ! 363 # define DIM_3d 364 # define ROUTINE_LNK mpp_lnk_3d 365 # include "mpp_lnk_generic.h90" 366 # undef ROUTINE_LNK 367 # define MULTI 368 # define ROUTINE_LNK mpp_lnk_3d_ptr 369 # include "mpp_lnk_generic.h90" 370 # undef ROUTINE_LNK 371 # undef MULTI 372 # undef DIM_3d 373 ! 374 ! !== 4D array and array of 4D pointer ==! 375 ! 376 # define DIM_4d 377 # define ROUTINE_LNK mpp_lnk_4d 378 # include "mpp_lnk_generic.h90" 379 # undef ROUTINE_LNK 380 # define MULTI 381 # define ROUTINE_LNK mpp_lnk_4d_ptr 382 # include "mpp_lnk_generic.h90" 383 # undef ROUTINE_LNK 384 # undef MULTI 385 # undef DIM_4d 386 387 !!---------------------------------------------------------------------- 388 !! *** routine mpp_nfd_(2,3,4)d *** 389 !! 390 !! * Argument : dummy argument use in mpp_nfd_... routines 391 !! ptab : array or pointer of arrays on which the boundary condition is applied 392 !! cd_nat : nature of array grid-points 393 !! psgn : sign used across the north fold boundary 394 !! kfld : optional, number of pt3d arrays 395 !! cd_mpp : optional, fill the overlap area only 396 !! pval : optional, background value (used at closed boundaries) 397 !!---------------------------------------------------------------------- 398 ! 399 ! !== 2D array and array of 2D pointer ==! 400 ! 401 # define DIM_2d 402 # define ROUTINE_NFD mpp_nfd_2d 403 # include "mpp_nfd_generic.h90" 404 # undef ROUTINE_NFD 405 # define MULTI 406 # define ROUTINE_NFD mpp_nfd_2d_ptr 407 # include "mpp_nfd_generic.h90" 408 # undef ROUTINE_NFD 409 # undef MULTI 410 # undef DIM_2d 411 ! 412 ! !== 3D array and array of 3D pointer ==! 413 ! 414 # define DIM_3d 415 # define ROUTINE_NFD mpp_nfd_3d 416 # include "mpp_nfd_generic.h90" 417 # undef ROUTINE_NFD 418 # define MULTI 419 # define ROUTINE_NFD mpp_nfd_3d_ptr 420 # include "mpp_nfd_generic.h90" 421 # undef ROUTINE_NFD 422 # undef MULTI 423 # undef DIM_3d 424 ! 425 ! !== 4D array and array of 4D pointer ==! 426 ! 427 # define DIM_4d 428 # define ROUTINE_NFD mpp_nfd_4d 429 # include "mpp_nfd_generic.h90" 430 # undef ROUTINE_NFD 431 # define MULTI 432 # define ROUTINE_NFD mpp_nfd_4d_ptr 433 # include "mpp_nfd_generic.h90" 434 # undef ROUTINE_NFD 435 # undef MULTI 436 # undef DIM_4d 437 438 439 !!---------------------------------------------------------------------- 440 !! *** routine mpp_lnk_bdy_(2,3,4)d *** 441 !! 442 !! * Argument : dummy argument use in mpp_lnk_... routines 443 !! ptab : array or pointer of arrays on which the boundary condition is applied 444 !! cd_nat : nature of array grid-points 445 !! psgn : sign used across the north fold boundary 446 !! kb_bdy : BDY boundary set 447 !! kfld : optional, number of pt3d arrays 448 !!---------------------------------------------------------------------- 449 ! 450 ! !== 2D array and array of 2D pointer ==! 451 ! 452 # define DIM_2d 453 # define ROUTINE_BDY mpp_lnk_bdy_2d 454 # include "mpp_bdy_generic.h90" 455 # undef ROUTINE_BDY 456 # define MULTI 457 # define ROUTINE_BDY mpp_lnk_bdy_2d_ptr 458 # include "mpp_bdy_generic.h90" 459 # undef ROUTINE_BDY 460 # undef MULTI 461 # undef DIM_2d 462 ! 463 ! !== 3D array and array of 3D pointer ==! 464 ! 465 # define DIM_3d 466 # define ROUTINE_BDY mpp_lnk_bdy_3d 467 # include "mpp_bdy_generic.h90" 468 # undef ROUTINE_BDY 469 # define MULTI 470 # define ROUTINE_BDY mpp_lnk_bdy_3d_ptr 471 # include "mpp_bdy_generic.h90" 472 # undef ROUTINE_BDY 473 # undef MULTI 474 # undef DIM_3d 475 ! 476 ! !== 4D array and array of 4D pointer ==! 477 ! 478 !!# define DIM_4d 479 !!# define ROUTINE_BDY mpp_lnk_bdy_4d 480 !!# include "mpp_bdy_generic.h90" 481 !!# undef ROUTINE_BDY 482 !!# define MULTI 483 !!# define ROUTINE_BDY mpp_lnk_bdy_4d_ptr 484 !!# include "mpp_bdy_generic.h90" 485 !!# undef ROUTINE_BDY 486 !!# undef MULTI 487 !!# undef DIM_4d 488 489 !!---------------------------------------------------------------------- 490 !! 491 !! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D 775 492 776 493 777 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 778 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 779 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 780 !!--------------------------------------------------------------------- 781 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA ! 2D arrays on which the lbc is applied 782 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 783 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 784 CHARACTER(len=1) , INTENT(in ) :: cd_typeA ! nature of pt2D. array grid-points 785 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 786 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 787 REAL(wp) , INTENT(in ) :: psgnA ! sign used across the north fold 788 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 789 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 790 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 791 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 792 !! 793 INTEGER :: kfld 794 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 795 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of pt2d array grid-points 796 REAL(wp) , DIMENSION(9) :: psgn_array ! sign used across the north fold boundary 797 !!--------------------------------------------------------------------- 798 ! 799 kfld = 0 800 ! 801 ! ! Load the first array 802 CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, kfld ) 803 ! 804 ! ! Look if more arrays are added 805 IF( PRESENT(psgnB) ) CALL load_array( pt2dB, cd_typeB, psgnB, pt2d_array, type_array, psgn_array, kfld ) 806 IF( PRESENT(psgnC) ) CALL load_array( pt2dC, cd_typeC, psgnC, pt2d_array, type_array, psgn_array, kfld ) 807 IF( PRESENT(psgnD) ) CALL load_array( pt2dD, cd_typeD, psgnD, pt2d_array, type_array, psgn_array, kfld ) 808 IF( PRESENT(psgnE) ) CALL load_array( pt2dE, cd_typeE, psgnE, pt2d_array, type_array, psgn_array, kfld ) 809 IF( PRESENT(psgnF) ) CALL load_array( pt2dF, cd_typeF, psgnF, pt2d_array, type_array, psgn_array, kfld ) 810 IF( PRESENT(psgnG) ) CALL load_array( pt2dG, cd_typeG, psgnG, pt2d_array, type_array, psgn_array, kfld ) 811 IF( PRESENT(psgnH) ) CALL load_array( pt2dH, cd_typeH, psgnH, pt2d_array, type_array, psgn_array, kfld ) 812 IF( PRESENT(psgnI) ) CALL load_array( pt2dI, cd_typeI, psgnI, pt2d_array, type_array, psgn_array, kfld ) 813 ! 814 CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp,pval ) 815 ! 816 END SUBROUTINE mpp_lnk_2d_9 817 818 819 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 820 !!---------------------------------------------------------------------- 821 !! *** routine mpp_lnk_2d *** 822 !! 823 !! ** Purpose : Message passing manadgement for 2d array 824 !! 825 !! ** Method : Use mppsend and mpprecv function for passing mask 826 !! between processors following neighboring subdomains. 827 !! domain parameters 828 !! nlci : first dimension of the local subdomain 829 !! nlcj : second dimension of the local subdomain 830 !! nbondi : mark for "east-west local boundary" 831 !! nbondj : mark for "north-south local boundary" 832 !! noea : number for local neighboring processors 833 !! nowe : number for local neighboring processors 834 !! noso : number for local neighboring processors 835 !! nono : number for local neighboring processors 836 !! 837 !!---------------------------------------------------------------------- 838 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 839 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points 840 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 841 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 842 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 843 !! 844 INTEGER :: ji, jj, jl ! dummy loop indices 845 INTEGER :: imigr, iihom, ijhom ! temporary integers 846 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 847 REAL(wp) :: zland 848 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 849 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 850 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 851 !!---------------------------------------------------------------------- 852 ! 853 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 854 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 855 ! 856 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 857 ELSE ; zland = 0._wp ! zero by default 858 ENDIF 859 860 ! 1. standard boundary treatment 861 ! ------------------------------ 862 ! 863 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 864 ! 865 ! WARNING pt2d is defined only between nld and nle 866 DO jj = nlcj+1, jpj ! added line(s) (inner only) 867 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 868 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) 869 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) 870 END DO 871 DO ji = nlci+1, jpi ! added column(s) (full) 872 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej) 873 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj ) 874 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej) 875 END DO 876 ! 877 ELSE ! standard close or cyclic treatment 878 ! 879 ! ! East-West boundaries 880 IF( nbondi == 2 .AND. & !* cyclic 881 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 882 pt2d( 1 ,:) = pt2d(jpim1,:) ! west 883 pt2d(jpi,:) = pt2d( 2 ,:) ! east 884 ELSE !* closed 885 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 886 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 887 ENDIF 888 ! ! North-South boundaries 889 ! !* cyclic 890 IF( nbondj == 2 .AND. jperio == 7 ) THEN 891 pt2d(:, 1 ) = pt2d(:,jpjm1) 892 pt2d(:, jpj) = pt2d(:, 2) 893 ELSE !* closed 894 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point 895 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north 896 ENDIF 897 ENDIF 898 899 ! 2. East and west directions exchange 900 ! ------------------------------------ 901 ! we play with the neigbours AND the row number because of the periodicity 902 ! 903 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 904 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 905 iihom = nlci-nreci 906 DO jl = 1, jpreci 907 zt2ew(:,jl,1) = pt2d(jpreci+jl,:) 908 zt2we(:,jl,1) = pt2d(iihom +jl,:) 909 END DO 910 END SELECT 911 ! 912 ! ! Migrations 913 imigr = jpreci * jpj 914 ! 915 SELECT CASE ( nbondi ) 916 CASE ( -1 ) 917 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 918 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 919 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 920 CASE ( 0 ) 921 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 922 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 923 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 924 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 925 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 926 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 927 CASE ( 1 ) 928 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 929 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 930 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 931 END SELECT 932 ! 933 ! ! Write Dirichlet lateral conditions 934 iihom = nlci - jpreci 935 ! 936 SELECT CASE ( nbondi ) 937 CASE ( -1 ) 938 DO jl = 1, jpreci 939 pt2d(iihom+jl,:) = zt2ew(:,jl,2) 940 END DO 941 CASE ( 0 ) 942 DO jl = 1, jpreci 943 pt2d(jl ,:) = zt2we(:,jl,2) 944 pt2d(iihom+jl,:) = zt2ew(:,jl,2) 945 END DO 946 CASE ( 1 ) 947 DO jl = 1, jpreci 948 pt2d(jl ,:) = zt2we(:,jl,2) 949 END DO 950 END SELECT 951 952 ! 3. North and south directions 953 ! ----------------------------- 954 ! always closed : we play only with the neigbours 955 ! 956 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 957 ijhom = nlcj-nrecj 958 DO jl = 1, jprecj 959 zt2sn(:,jl,1) = pt2d(:,ijhom +jl) 960 zt2ns(:,jl,1) = pt2d(:,jprecj+jl) 961 END DO 962 ENDIF 963 ! 964 ! ! Migrations 965 imigr = jprecj * jpi 966 ! 967 SELECT CASE ( nbondj ) 968 CASE ( -1 ) 969 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 970 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 971 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 972 CASE ( 0 ) 973 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 974 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 975 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 976 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 977 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 978 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 979 CASE ( 1 ) 980 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 981 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 982 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 983 END SELECT 984 ! 985 ! ! Write Dirichlet lateral conditions 986 ijhom = nlcj - jprecj 987 ! 988 SELECT CASE ( nbondj ) 989 CASE ( -1 ) 990 DO jl = 1, jprecj 991 pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 992 END DO 993 CASE ( 0 ) 994 DO jl = 1, jprecj 995 pt2d(:,jl ) = zt2sn(:,jl,2) 996 pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 997 END DO 998 CASE ( 1 ) 999 DO jl = 1, jprecj 1000 pt2d(:,jl ) = zt2sn(:,jl,2) 1001 END DO 1002 END SELECT 1003 1004 ! 4. north fold treatment 1005 ! ----------------------- 1006 ! 1007 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1008 ! 1009 SELECT CASE ( jpni ) 1010 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp 1011 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. 1012 END SELECT 1013 ! 1014 ENDIF 1015 ! 1016 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 1017 ! 1018 END SUBROUTINE mpp_lnk_2d 1019 1020 1021 SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 1022 !!---------------------------------------------------------------------- 1023 !! *** routine mpp_lnk_3d_gather *** 1024 !! 1025 !! ** Purpose : Message passing manadgement for two 3D arrays 1026 !! 1027 !! ** Method : Use mppsend and mpprecv function for passing mask 1028 !! between processors following neighboring subdomains. 1029 !! domain parameters 1030 !! nlci : first dimension of the local subdomain 1031 !! nlcj : second dimension of the local subdomain 1032 !! nbondi : mark for "east-west local boundary" 1033 !! nbondj : mark for "north-south local boundary" 1034 !! noea : number for local neighboring processors 1035 !! nowe : number for local neighboring processors 1036 !! noso : number for local neighboring processors 1037 !! nono : number for local neighboring processors 1038 !! 1039 !! ** Action : ptab1 and ptab2 with update value at its periphery 1040 !! 1041 !!---------------------------------------------------------------------- 1042 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab1 ! 1st 3D array on which the boundary condition is applied 1043 CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 arrays 1044 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab2 ! 3nd 3D array on which the boundary condition is applied 1045 CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! nature of ptab2 arrays 1046 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 1047 ! 1048 INTEGER :: jl ! dummy loop indices 1049 INTEGER :: ipk ! 3rd dimension of the input array 1050 INTEGER :: imigr, iihom, ijhom ! temporary integers 1051 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1052 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1053 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ns, zt4sn ! 2 x 3d for north-south & south-north 1054 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ew, zt4we ! 2 x 3d for east-west & west-east 1055 !!---------------------------------------------------------------------- 1056 ! 1057 ipk = SIZE( ptab1, 3 ) 1058 ! 1059 ALLOCATE( zt4ns(jpi,jprecj,ipk,2,2), zt4sn(jpi,jprecj,ipk,2,2) , & 1060 & zt4ew(jpj,jpreci,ipk,2,2), zt4we(jpj,jpreci,ipk,2,2) ) 1061 1062 ! 1. standard boundary treatment 1063 ! ------------------------------ 1064 ! ! East-West boundaries 1065 ! !* Cyclic 1066 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1067 ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 1068 ptab1(jpi,:,:) = ptab1( 2 ,:,:) 1069 ptab2( 1 ,:,:) = ptab2(jpim1,:,:) 1070 ptab2(jpi,:,:) = ptab2( 2 ,:,:) 1071 ELSE !* closed 1072 IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0._wp ! south except at F-point 1073 IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0._wp 1074 ptab1(nlci-jpreci+1:jpi ,:,:) = 0._wp ! north 1075 ptab2(nlci-jpreci+1:jpi ,:,:) = 0._wp 1076 ENDIF 1077 ! ! North-South boundaries 1078 ! !* cyclic 1079 IF( nbondj == 2 .AND. jperio == 7 ) THEN 1080 ptab1(:, 1 ,:) = ptab1(:, jpjm1 , :) 1081 ptab1(:, jpj ,:) = ptab1(:, 2 , :) 1082 ptab2(:, 1 ,:) = ptab2(:, jpjm1 , :) 1083 ptab2(:, jpj ,:) = ptab2(:, 2 , :) 1084 ELSE 1085 ! !* closed 1086 IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0._wp ! south except at F-point 1087 IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0._wp 1088 ptab1(:,nlcj-jprecj+1:jpj ,:) = 0._wp ! north 1089 ptab2(:,nlcj-jprecj+1:jpj ,:) = 0._wp 1090 ENDIF 1091 1092 ! 2. East and west directions exchange 1093 ! ------------------------------------ 1094 ! we play with the neigbours AND the row number because of the periodicity 1095 ! 1096 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 1097 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1098 iihom = nlci-nreci 1099 DO jl = 1, jpreci 1100 zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 1101 zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 1102 zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 1103 zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 1104 END DO 1105 END SELECT 1106 ! 1107 ! ! Migrations 1108 imigr = jpreci * jpj * ipk *2 1109 ! 1110 SELECT CASE ( nbondi ) 1111 CASE ( -1 ) 1112 CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 ) 1113 CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 1114 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1115 CASE ( 0 ) 1116 CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1117 CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 ) 1118 CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 1119 CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 1120 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1121 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1122 CASE ( 1 ) 1123 CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1124 CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 1125 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1126 END SELECT 1127 ! 1128 ! ! Write Dirichlet lateral conditions 1129 iihom = nlci - jpreci 1130 ! 1131 SELECT CASE ( nbondi ) 1132 CASE ( -1 ) 1133 DO jl = 1, jpreci 1134 ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 1135 ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 1136 END DO 1137 CASE ( 0 ) 1138 DO jl = 1, jpreci 1139 ptab1(jl ,:,:) = zt4we(:,jl,:,1,2) 1140 ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 1141 ptab2(jl ,:,:) = zt4we(:,jl,:,2,2) 1142 ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 1143 END DO 1144 CASE ( 1 ) 1145 DO jl = 1, jpreci 1146 ptab1(jl ,:,:) = zt4we(:,jl,:,1,2) 1147 ptab2(jl ,:,:) = zt4we(:,jl,:,2,2) 1148 END DO 1149 END SELECT 1150 1151 ! 3. North and south directions 1152 ! ----------------------------- 1153 ! always closed : we play only with the neigbours 1154 ! 1155 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1156 ijhom = nlcj - nrecj 1157 DO jl = 1, jprecj 1158 zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 1159 zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 1160 zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 1161 zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 1162 END DO 1163 ENDIF 1164 ! 1165 ! ! Migrations 1166 imigr = jprecj * jpi * ipk * 2 1167 ! 1168 SELECT CASE ( nbondj ) 1169 CASE ( -1 ) 1170 CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 1171 CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 1172 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1173 CASE ( 0 ) 1174 CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1175 CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 1176 CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 1177 CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 1178 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1179 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1180 CASE ( 1 ) 1181 CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1182 CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 1183 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1184 END SELECT 1185 ! 1186 ! ! Write Dirichlet lateral conditions 1187 ijhom = nlcj - jprecj 1188 ! 1189 SELECT CASE ( nbondj ) 1190 CASE ( -1 ) 1191 DO jl = 1, jprecj 1192 ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 1193 ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 1194 END DO 1195 CASE ( 0 ) 1196 DO jl = 1, jprecj 1197 ptab1(:,jl ,:) = zt4sn(:,jl,:,1,2) 1198 ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 1199 ptab2(:,jl ,:) = zt4sn(:,jl,:,2,2) 1200 ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 1201 END DO 1202 CASE ( 1 ) 1203 DO jl = 1, jprecj 1204 ptab1(:,jl,:) = zt4sn(:,jl,:,1,2) 1205 ptab2(:,jl,:) = zt4sn(:,jl,:,2,2) 1206 END DO 1207 END SELECT 1208 1209 ! 4. north fold treatment 1210 ! ----------------------- 1211 IF( npolj /= 0 ) THEN 1212 ! 1213 SELECT CASE ( jpni ) 1214 CASE ( 1 ) 1215 CALL lbc_nfd ( ptab1, cd_type1, psgn ) ! only for northern procs. 1216 CALL lbc_nfd ( ptab2, cd_type2, psgn ) 1217 CASE DEFAULT 1218 CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs. 1219 CALL mpp_lbc_north (ptab2, cd_type2, psgn) 1220 END SELECT 1221 ! 1222 ENDIF 1223 ! 1224 DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we ) 1225 ! 1226 END SUBROUTINE mpp_lnk_3d_gather 494 !! mpp_lnk_2d_e utilisé dans ICB 495 496 497 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 498 499 500 !!---------------------------------------------------------------------- 1227 501 1228 502 … … 1297 571 ! 1298 572 SELECT CASE ( jpni ) 1299 1300 CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )573 !!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 574 !!gm ERROR CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn ) 1301 575 END SELECT 1302 576 ! … … 1411 685 1412 686 1413 SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval )1414 !!----------------------------------------------------------------------1415 !! *** routine mpp_lnk_sum_3d ***1416 !!1417 !! ** Purpose : Message passing manadgement (sum the overlap region)1418 !!1419 !! ** Method : Use mppsend and mpprecv function for passing mask1420 !! between processors following neighboring subdomains.1421 !! domain parameters1422 !! nlci : first dimension of the local subdomain1423 !! nlcj : second dimension of the local subdomain1424 !! nbondi : mark for "east-west local boundary"1425 !! nbondj : mark for "north-south local boundary"1426 !! noea : number for local neighboring processors1427 !! nowe : number for local neighboring processors1428 !! noso : number for local neighboring processors1429 !! nono : number for local neighboring processors1430 !!1431 !! ** Action : ptab with update value at its periphery1432 !!1433 !!----------------------------------------------------------------------1434 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied1435 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1436 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary1437 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only1438 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)1439 !1440 INTEGER :: ji, jj, jk, jl ! dummy loop indices1441 INTEGER :: imigr, iihom, ijhom ! temporary integers1442 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1443 REAL(wp) :: zland1444 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1445 !1446 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north1447 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east1448 !!----------------------------------------------------------------------1449 !1450 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), &1451 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) )1452 !1453 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value1454 ELSE ; zland = 0._wp ! zero by default1455 ENDIF1456 1457 ! 1. standard boundary treatment1458 ! ------------------------------1459 ! 2. East and west directions exchange1460 ! ------------------------------------1461 ! we play with the neigbours AND the row number because of the periodicity1462 !1463 SELECT CASE ( nbondi ) ! Read lateral conditions1464 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1465 iihom = nlci-jpreci1466 DO jl = 1, jpreci1467 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0._wp1468 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0._wp1469 END DO1470 END SELECT1471 !1472 ! ! Migrations1473 imigr = jpreci * jpj * jpk1474 !1475 SELECT CASE ( nbondi )1476 CASE ( -1 )1477 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )1478 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )1479 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1480 CASE ( 0 )1481 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )1482 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )1483 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )1484 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )1485 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1486 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)1487 CASE ( 1 )1488 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )1489 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )1490 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1491 END SELECT1492 !1493 ! ! Write lateral conditions1494 iihom = nlci-nreci1495 !1496 SELECT CASE ( nbondi )1497 CASE ( -1 )1498 DO jl = 1, jpreci1499 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2)1500 END DO1501 CASE ( 0 )1502 DO jl = 1, jpreci1503 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2)1504 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2)1505 END DO1506 CASE ( 1 )1507 DO jl = 1, jpreci1508 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2)1509 END DO1510 END SELECT1511 1512 ! 3. North and south directions1513 ! -----------------------------1514 ! always closed : we play only with the neigbours1515 !1516 IF( nbondj /= 2 ) THEN ! Read lateral conditions1517 ijhom = nlcj-jprecj1518 DO jl = 1, jprecj1519 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0._wp1520 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0._wp1521 END DO1522 ENDIF1523 !1524 ! ! Migrations1525 imigr = jprecj * jpi * jpk1526 !1527 SELECT CASE ( nbondj )1528 CASE ( -1 )1529 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )1530 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )1531 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1532 CASE ( 0 )1533 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )1534 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )1535 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )1536 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )1537 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1538 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)1539 CASE ( 1 )1540 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )1541 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )1542 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1543 END SELECT1544 !1545 ! ! Write lateral conditions1546 ijhom = nlcj-nrecj1547 !1548 SELECT CASE ( nbondj )1549 CASE ( -1 )1550 DO jl = 1, jprecj1551 ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2)1552 END DO1553 CASE ( 0 )1554 DO jl = 1, jprecj1555 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2)1556 ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2)1557 END DO1558 CASE ( 1 )1559 DO jl = 1, jprecj1560 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl ,:,2)1561 END DO1562 END SELECT1563 1564 ! 4. north fold treatment1565 ! -----------------------1566 !1567 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN1568 !1569 SELECT CASE ( jpni )1570 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp1571 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.1572 END SELECT1573 !1574 ENDIF1575 !1576 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )1577 !1578 END SUBROUTINE mpp_lnk_sum_3d1579 1580 1581 SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval )1582 !!----------------------------------------------------------------------1583 !! *** routine mpp_lnk_sum_2d ***1584 !!1585 !! ** Purpose : Message passing manadgement for 2d array (sum the overlap region)1586 !!1587 !! ** Method : Use mppsend and mpprecv function for passing mask1588 !! between processors following neighboring subdomains.1589 !! domain parameters1590 !! nlci : first dimension of the local subdomain1591 !! nlcj : second dimension of the local subdomain1592 !! nbondi : mark for "east-west local boundary"1593 !! nbondj : mark for "north-south local boundary"1594 !! noea : number for local neighboring processors1595 !! nowe : number for local neighboring processors1596 !! noso : number for local neighboring processors1597 !! nono : number for local neighboring processors1598 !!----------------------------------------------------------------------1599 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied1600 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points1601 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary1602 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only1603 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)1604 !!1605 INTEGER :: ji, jj, jl ! dummy loop indices1606 INTEGER :: imigr, iihom, ijhom ! temporary integers1607 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1608 REAL(wp) :: zland1609 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1610 !1611 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north1612 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east1613 !!----------------------------------------------------------------------1614 !1615 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &1616 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )1617 !1618 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value1619 ELSE ; zland = 0._wp ! zero by default1620 ENDIF1621 1622 ! 1. standard boundary treatment1623 ! ------------------------------1624 ! 2. East and west directions exchange1625 ! ------------------------------------1626 ! we play with the neigbours AND the row number because of the periodicity1627 !1628 SELECT CASE ( nbondi ) ! Read lateral conditions1629 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1630 iihom = nlci - jpreci1631 DO jl = 1, jpreci1632 zt2ew(:,jl,1) = pt2d(jl ,:) ; pt2d(jl ,:) = 0.0_wp1633 zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp1634 END DO1635 END SELECT1636 !1637 ! ! Migrations1638 imigr = jpreci * jpj1639 !1640 SELECT CASE ( nbondi )1641 CASE ( -1 )1642 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )1643 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )1644 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1645 CASE ( 0 )1646 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )1647 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )1648 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )1649 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )1650 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1651 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1652 CASE ( 1 )1653 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )1654 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )1655 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1656 END SELECT1657 !1658 ! ! Write lateral conditions1659 iihom = nlci-nreci1660 !1661 SELECT CASE ( nbondi )1662 CASE ( -1 )1663 DO jl = 1, jpreci1664 pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2)1665 END DO1666 CASE ( 0 )1667 DO jl = 1, jpreci1668 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2)1669 pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2)1670 END DO1671 CASE ( 1 )1672 DO jl = 1, jpreci1673 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2)1674 END DO1675 END SELECT1676 1677 1678 ! 3. North and south directions1679 ! -----------------------------1680 ! always closed : we play only with the neigbours1681 !1682 IF( nbondj /= 2 ) THEN ! Read lateral conditions1683 ijhom = nlcj - jprecj1684 DO jl = 1, jprecj1685 zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp1686 zt2ns(:,jl,1) = pt2d(:,jl ) ; pt2d(:,jl ) = 0.0_wp1687 END DO1688 ENDIF1689 !1690 ! ! Migrations1691 imigr = jprecj * jpi1692 !1693 SELECT CASE ( nbondj )1694 CASE ( -1 )1695 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )1696 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )1697 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1698 CASE ( 0 )1699 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )1700 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )1701 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )1702 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )1703 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1704 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1705 CASE ( 1 )1706 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )1707 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )1708 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1709 END SELECT1710 !1711 ! ! Write lateral conditions1712 ijhom = nlcj-nrecj1713 !1714 SELECT CASE ( nbondj )1715 CASE ( -1 )1716 DO jl = 1, jprecj1717 pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2)1718 END DO1719 CASE ( 0 )1720 DO jl = 1, jprecj1721 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2)1722 pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2)1723 END DO1724 CASE ( 1 )1725 DO jl = 1, jprecj1726 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2)1727 END DO1728 END SELECT1729 1730 ! 4. north fold treatment1731 ! -----------------------1732 !1733 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN1734 !1735 SELECT CASE ( jpni )1736 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp1737 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.1738 END SELECT1739 !1740 ENDIF1741 !1742 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )1743 !1744 END SUBROUTINE mpp_lnk_sum_2d1745 1746 1747 687 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) 1748 688 !!---------------------------------------------------------------------- … … 1845 785 END SUBROUTINE mppscatter 1846 786 1847 787 !!---------------------------------------------------------------------- 788 !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** 789 !! 790 !!---------------------------------------------------------------------- 791 !! 1848 792 SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 1849 !!----------------------------------------------------------------------1850 !! *** routine mppmax_a_int ***1851 !!1852 !! ** Purpose : Find maximum value in an integer layout array1853 !!1854 793 !!---------------------------------------------------------------------- 1855 794 INTEGER , INTENT(in ) :: kdim ! size of array 1856 795 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1857 796 INTEGER , INTENT(in ), OPTIONAL :: kcom ! 1858 ! 1859 INTEGER :: ierror, localcomm ! temporary integer 797 INTEGER :: ierror, ilocalcomm ! temporary integer 1860 798 INTEGER, DIMENSION(kdim) :: iwork 1861 799 !!---------------------------------------------------------------------- 1862 ! 1863 localcomm = mpi_comm_opa 1864 IF( PRESENT(kcom) ) localcomm = kcom 1865 ! 1866 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror ) 1867 ! 800 ilocalcomm = mpi_comm_opa 801 IF( PRESENT(kcom) ) ilocalcomm = kcom 802 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror ) 1868 803 ktab(:) = iwork(:) 1869 !1870 804 END SUBROUTINE mppmax_a_int 1871 1872 805 !! 1873 806 SUBROUTINE mppmax_int( ktab, kcom ) 1874 !!----------------------------------------------------------------------1875 !! *** routine mppmax_int ***1876 !!1877 !! ** Purpose : Find maximum value in an integer layout array1878 !!1879 807 !!---------------------------------------------------------------------- 1880 808 INTEGER, INTENT(inout) :: ktab ! ??? 1881 809 INTEGER, INTENT(in ), OPTIONAL :: kcom ! ??? 1882 ! 1883 INTEGER :: ierror, iwork, localcomm ! temporary integer 1884 !!---------------------------------------------------------------------- 1885 ! 1886 localcomm = mpi_comm_opa 1887 IF( PRESENT(kcom) ) localcomm = kcom 1888 ! 1889 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 1890 ! 810 INTEGER :: ierror, iwork, ilocalcomm ! temporary integer 811 !!---------------------------------------------------------------------- 812 ilocalcomm = mpi_comm_opa 813 IF( PRESENT(kcom) ) ilocalcomm = kcom 814 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, ilocalcomm, ierror ) 1891 815 ktab = iwork 1892 !1893 816 END SUBROUTINE mppmax_int 1894 1895 817 !! 818 SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 819 !!---------------------------------------------------------------------- 820 REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab 821 INTEGER , INTENT(in ) :: kdim 822 INTEGER , OPTIONAL , INTENT(in ) :: kcom 823 INTEGER :: ierror, ilocalcomm 824 REAL(wp), DIMENSION(kdim) :: zwork 825 !!---------------------------------------------------------------------- 826 ilocalcomm = mpi_comm_opa 827 IF( PRESENT(kcom) ) ilocalcomm = kcom 828 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 829 ptab(:) = zwork(:) 830 END SUBROUTINE mppmax_a_real 831 !! 832 SUBROUTINE mppmax_real( ptab, kcom ) 833 !!---------------------------------------------------------------------- 834 REAL(wp), INTENT(inout) :: ptab ! ??? 835 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 836 INTEGER :: ierror, ilocalcomm 837 REAL(wp) :: zwork 838 !!---------------------------------------------------------------------- 839 ilocalcomm = mpi_comm_opa 840 IF( PRESENT(kcom) ) ilocalcomm = kcom! 841 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 842 ptab = zwork 843 END SUBROUTINE mppmax_real 844 845 846 !!---------------------------------------------------------------------- 847 !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** 848 !! 849 !!---------------------------------------------------------------------- 850 !! 1896 851 SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 1897 !!----------------------------------------------------------------------1898 !! *** routine mppmin_a_int ***1899 !!1900 !! ** Purpose : Find minimum value in an integer layout array1901 !!1902 852 !!---------------------------------------------------------------------- 1903 853 INTEGER , INTENT( in ) :: kdim ! size of array … … 1905 855 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 1906 856 !! 1907 INTEGER :: ierror, localcomm ! temporary integer857 INTEGER :: ierror, ilocalcomm ! temporary integer 1908 858 INTEGER, DIMENSION(kdim) :: iwork 1909 859 !!---------------------------------------------------------------------- 1910 ! 1911 localcomm = mpi_comm_opa 1912 IF( PRESENT(kcom) ) localcomm = kcom 1913 ! 1914 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror ) 1915 ! 860 ilocalcomm = mpi_comm_opa 861 IF( PRESENT(kcom) ) ilocalcomm = kcom 862 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror ) 1916 863 ktab(:) = iwork(:) 1917 !1918 864 END SUBROUTINE mppmin_a_int 1919 1920 865 !! 1921 866 SUBROUTINE mppmin_int( ktab, kcom ) 1922 !!----------------------------------------------------------------------1923 !! *** routine mppmin_int ***1924 !!1925 !! ** Purpose : Find minimum value in an integer layout array1926 !!1927 867 !!---------------------------------------------------------------------- 1928 868 INTEGER, INTENT(inout) :: ktab ! ??? 1929 869 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 1930 870 !! 1931 INTEGER :: ierror, iwork, localcomm 1932 !!---------------------------------------------------------------------- 1933 ! 1934 localcomm = mpi_comm_opa 1935 IF( PRESENT(kcom) ) localcomm = kcom 1936 ! 1937 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 1938 ! 871 INTEGER :: ierror, iwork, ilocalcomm 872 !!---------------------------------------------------------------------- 873 ilocalcomm = mpi_comm_opa 874 IF( PRESENT(kcom) ) ilocalcomm = kcom 875 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, ilocalcomm, ierror ) 1939 876 ktab = iwork 1940 !1941 877 END SUBROUTINE mppmin_int 1942 1943 878 !! 879 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 880 !!---------------------------------------------------------------------- 881 INTEGER , INTENT(in ) :: kdim 882 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 883 INTEGER , INTENT(in ), OPTIONAL :: kcom 884 INTEGER :: ierror, ilocalcomm 885 REAL(wp), DIMENSION(kdim) :: zwork 886 !!----------------------------------------------------------------------- 887 ilocalcomm = mpi_comm_opa 888 IF( PRESENT(kcom) ) ilocalcomm = kcom 889 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 890 ptab(:) = zwork(:) 891 END SUBROUTINE mppmin_a_real 892 !! 893 SUBROUTINE mppmin_real( ptab, kcom ) 894 !!----------------------------------------------------------------------- 895 REAL(wp), INTENT(inout) :: ptab ! 896 INTEGER , INTENT(in ), OPTIONAL :: kcom 897 INTEGER :: ierror, ilocalcomm 898 REAL(wp) :: zwork 899 !!----------------------------------------------------------------------- 900 ilocalcomm = mpi_comm_opa 901 IF( PRESENT(kcom) ) ilocalcomm = kcom 902 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 903 ptab = zwork 904 END SUBROUTINE mppmin_real 905 906 907 !!---------------------------------------------------------------------- 908 !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** 909 !! 910 !! Global sum of 1D array or a variable (integer, real or complex) 911 !!---------------------------------------------------------------------- 912 !! 1944 913 SUBROUTINE mppsum_a_int( ktab, kdim ) 1945 !!----------------------------------------------------------------------1946 !! *** routine mppsum_a_int ***1947 !!1948 !! ** Purpose : Global integer sum, 1D array case1949 !!1950 914 !!---------------------------------------------------------------------- 1951 915 INTEGER, INTENT(in ) :: kdim ! ??? 1952 916 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? 1953 !1954 917 INTEGER :: ierror 1955 918 INTEGER, DIMENSION (kdim) :: iwork 1956 919 !!---------------------------------------------------------------------- 1957 !1958 920 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 1959 !1960 921 ktab(:) = iwork(:) 1961 !1962 922 END SUBROUTINE mppsum_a_int 1963 1964 923 !! 1965 924 SUBROUTINE mppsum_int( ktab ) 1966 925 !!---------------------------------------------------------------------- 1967 !! *** routine mppsum_int ***1968 !!1969 !! ** Purpose : Global integer sum1970 !!1971 !!----------------------------------------------------------------------1972 926 INTEGER, INTENT(inout) :: ktab 1973 !!1974 927 INTEGER :: ierror, iwork 1975 928 !!---------------------------------------------------------------------- 1976 !1977 929 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 1978 !1979 930 ktab = iwork 1980 !1981 931 END SUBROUTINE mppsum_int 1982 1983 1984 SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 1985 !!---------------------------------------------------------------------- 1986 !! *** routine mppmax_a_real *** 1987 !! 1988 !! ** Purpose : Maximum of a 1D array 1989 !! 1990 !!---------------------------------------------------------------------- 1991 REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab 1992 INTEGER , INTENT(in ) :: kdim 1993 INTEGER , OPTIONAL , INTENT(in ) :: kcom 1994 ! 1995 INTEGER :: ierror, localcomm 1996 REAL(wp), DIMENSION(kdim) :: zwork 1997 !!---------------------------------------------------------------------- 1998 ! 1999 localcomm = mpi_comm_opa 2000 IF( PRESENT(kcom) ) localcomm = kcom 2001 ! 2002 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 932 !! 933 SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 934 !!----------------------------------------------------------------------- 935 INTEGER , INTENT(in ) :: kdim ! size of ptab 936 REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab ! input array 937 INTEGER , OPTIONAL , INTENT(in ) :: kcom ! specific communicator 938 INTEGER :: ierror, ilocalcomm ! local integer 939 REAL(wp) :: zwork(kdim) ! local workspace 940 !!----------------------------------------------------------------------- 941 ilocalcomm = mpi_comm_opa 942 IF( PRESENT(kcom) ) ilocalcomm = kcom 943 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 2003 944 ptab(:) = zwork(:) 2004 ! 2005 END SUBROUTINE mppmax_a_real 2006 2007 2008 SUBROUTINE mppmax_real( ptab, kcom ) 945 END SUBROUTINE mppsum_a_real 946 !! 947 SUBROUTINE mppsum_real( ptab, kcom ) 948 !!----------------------------------------------------------------------- 949 REAL(wp) , INTENT(inout) :: ptab ! input scalar 950 INTEGER , OPTIONAL, INTENT(in ) :: kcom 951 INTEGER :: ierror, ilocalcomm 952 REAL(wp) :: zwork 953 !!----------------------------------------------------------------------- 954 ilocalcomm = mpi_comm_opa 955 IF( PRESENT(kcom) ) ilocalcomm = kcom 956 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 957 ptab = zwork 958 END SUBROUTINE mppsum_real 959 !! 960 SUBROUTINE mppsum_realdd( ytab, kcom ) 961 !!----------------------------------------------------------------------- 962 COMPLEX(wp) , INTENT(inout) :: ytab ! input scalar 963 INTEGER , OPTIONAL, INTENT(in ) :: kcom 964 INTEGER :: ierror, ilocalcomm 965 COMPLEX(wp) :: zwork 966 !!----------------------------------------------------------------------- 967 ilocalcomm = mpi_comm_opa 968 IF( PRESENT(kcom) ) ilocalcomm = kcom 969 CALL MPI_ALLREDUCE( ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 970 ytab = zwork 971 END SUBROUTINE mppsum_realdd 972 !! 973 SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 974 !!---------------------------------------------------------------------- 975 INTEGER , INTENT(in ) :: kdim ! size of ytab 976 COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array 977 INTEGER , OPTIONAL , INTENT(in ) :: kcom 978 INTEGER:: ierror, ilocalcomm ! local integer 979 COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace 980 !!----------------------------------------------------------------------- 981 ilocalcomm = mpi_comm_opa 982 IF( PRESENT(kcom) ) ilocalcomm = kcom 983 CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 984 ytab(:) = zwork(:) 985 END SUBROUTINE mppsum_a_realdd 986 987 988 SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom ) 2009 989 !!---------------------------------------------------------------------- 2010 990 !! *** routine mppmax_real *** 2011 991 !! 2012 !! ** Purpose : Maximum for each element of a 1D array 2013 !! 2014 !!---------------------------------------------------------------------- 2015 REAL(wp), INTENT(inout) :: ptab ! ??? 2016 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 2017 !! 2018 INTEGER :: ierror, localcomm 2019 REAL(wp) :: zwork 2020 !!---------------------------------------------------------------------- 2021 ! 2022 localcomm = mpi_comm_opa 2023 IF( PRESENT(kcom) ) localcomm = kcom 2024 ! 2025 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror ) 2026 ptab = zwork 2027 ! 2028 END SUBROUTINE mppmax_real 2029 2030 2031 SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom ) 2032 !!---------------------------------------------------------------------- 2033 !! *** routine mppmax_real *** 2034 !! 2035 !! ** Purpose : Maximum 992 !! ** Purpose : Maximum across processor of each element of a 1D arrays 2036 993 !! 2037 994 !!---------------------------------------------------------------------- … … 2040 997 INTEGER , OPTIONAL , INTENT(in ) :: kcom ! local communicator 2041 998 !! 2042 INTEGER :: ierror, localcomm999 INTEGER :: ierror, ilocalcomm 2043 1000 REAL(wp), DIMENSION(kdim) :: zwork 2044 1001 !!---------------------------------------------------------------------- 2045 ! 2046 localcomm = mpi_comm_opa 2047 IF( PRESENT(kcom) ) localcomm = kcom 2048 ! 2049 CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 1002 ilocalcomm = mpi_comm_opa 1003 IF( PRESENT(kcom) ) ilocalcomm = kcom 1004 ! 1005 CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 2050 1006 pt1d(:) = zwork(:) 2051 1007 ! 2052 1008 END SUBROUTINE mppmax_real_multiple 2053 2054 2055 SUBROUTINE mppmin_a_real( ptab, kdim, kcom )2056 !!----------------------------------------------------------------------2057 !! *** routine mppmin_a_real ***2058 !!2059 !! ** Purpose : Minimum of REAL, array case2060 !!2061 !!-----------------------------------------------------------------------2062 INTEGER , INTENT(in ) :: kdim2063 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab2064 INTEGER , INTENT(in ), OPTIONAL :: kcom2065 !!2066 INTEGER :: ierror, localcomm2067 REAL(wp), DIMENSION(kdim) :: zwork2068 !!-----------------------------------------------------------------------2069 !2070 localcomm = mpi_comm_opa2071 IF( PRESENT(kcom) ) localcomm = kcom2072 !2073 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )2074 ptab(:) = zwork(:)2075 !2076 END SUBROUTINE mppmin_a_real2077 2078 2079 SUBROUTINE mppmin_real( ptab, kcom )2080 !!----------------------------------------------------------------------2081 !! *** routine mppmin_real ***2082 !!2083 !! ** Purpose : minimum of REAL, scalar case2084 !!2085 !!-----------------------------------------------------------------------2086 REAL(wp), INTENT(inout) :: ptab !2087 INTEGER , INTENT(in ), OPTIONAL :: kcom2088 !!2089 INTEGER :: ierror2090 REAL(wp) :: zwork2091 INTEGER :: localcomm2092 !!-----------------------------------------------------------------------2093 !2094 localcomm = mpi_comm_opa2095 IF( PRESENT(kcom) ) localcomm = kcom2096 !2097 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )2098 ptab = zwork2099 !2100 END SUBROUTINE mppmin_real2101 2102 2103 SUBROUTINE mppsum_a_real( ptab, kdim, kcom )2104 !!----------------------------------------------------------------------2105 !! *** routine mppsum_a_real ***2106 !!2107 !! ** Purpose : global sum, REAL ARRAY argument case2108 !!2109 !!-----------------------------------------------------------------------2110 INTEGER , INTENT( in ) :: kdim ! size of ptab2111 REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array2112 INTEGER , INTENT( in ), OPTIONAL :: kcom2113 !!2114 INTEGER :: ierror ! temporary integer2115 INTEGER :: localcomm2116 REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace2117 !!-----------------------------------------------------------------------2118 !2119 localcomm = mpi_comm_opa2120 IF( PRESENT(kcom) ) localcomm = kcom2121 !2122 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )2123 ptab(:) = zwork(:)2124 !2125 END SUBROUTINE mppsum_a_real2126 2127 2128 SUBROUTINE mppsum_real( ptab, kcom )2129 !!----------------------------------------------------------------------2130 !! *** routine mppsum_real ***2131 !!2132 !! ** Purpose : global sum, SCALAR argument case2133 !!2134 !!-----------------------------------------------------------------------2135 REAL(wp), INTENT(inout) :: ptab ! input scalar2136 INTEGER , INTENT(in ), OPTIONAL :: kcom2137 !!2138 INTEGER :: ierror, localcomm2139 REAL(wp) :: zwork2140 !!-----------------------------------------------------------------------2141 !2142 localcomm = mpi_comm_opa2143 IF( PRESENT(kcom) ) localcomm = kcom2144 !2145 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )2146 ptab = zwork2147 !2148 END SUBROUTINE mppsum_real2149 2150 2151 SUBROUTINE mppsum_realdd( ytab, kcom )2152 !!----------------------------------------------------------------------2153 !! *** routine mppsum_realdd ***2154 !!2155 !! ** Purpose : global sum in Massively Parallel Processing2156 !! SCALAR argument case for double-double precision2157 !!2158 !!-----------------------------------------------------------------------2159 COMPLEX(wp), INTENT(inout) :: ytab ! input scalar2160 INTEGER , INTENT(in ), OPTIONAL :: kcom2161 !2162 INTEGER :: ierror2163 INTEGER :: localcomm2164 COMPLEX(wp) :: zwork2165 !!-----------------------------------------------------------------------2166 !2167 localcomm = mpi_comm_opa2168 IF( PRESENT(kcom) ) localcomm = kcom2169 !2170 ! reduce local sums into global sum2171 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror )2172 ytab = zwork2173 !2174 END SUBROUTINE mppsum_realdd2175 2176 2177 SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )2178 !!----------------------------------------------------------------------2179 !! *** routine mppsum_a_realdd ***2180 !!2181 !! ** Purpose : global sum in Massively Parallel Processing2182 !! COMPLEX ARRAY case for double-double precision2183 !!2184 !!-----------------------------------------------------------------------2185 INTEGER , INTENT(in ) :: kdim ! size of ytab2186 COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array2187 INTEGER , OPTIONAL , INTENT(in ) :: kcom2188 !2189 INTEGER:: ierror, localcomm ! local integer2190 COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace2191 !!-----------------------------------------------------------------------2192 !2193 localcomm = mpi_comm_opa2194 IF( PRESENT(kcom) ) localcomm = kcom2195 !2196 CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror )2197 ytab(:) = zwork(:)2198 !2199 END SUBROUTINE mppsum_a_realdd2200 1009 2201 1010 … … 2649 1458 2650 1459 2651 SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )2652 !!---------------------------------------------------------------------2653 !! *** routine mpp_lbc_north_3d ***2654 !!2655 !! ** Purpose : Ensure proper north fold horizontal bondary condition2656 !! in mpp configuration in case of jpn1 > 12657 !!2658 !! ** Method : North fold condition and mpp with more than one proc2659 !! in i-direction require a specific treatment. We gather2660 !! the 4 northern lines of the global domain on 1 processor2661 !! and apply lbc north-fold on this sub array. Then we2662 !! scatter the north fold array back to the processors.2663 !!----------------------------------------------------------------------2664 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied2665 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points2666 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold2667 !2668 INTEGER :: ji, jj, jr, jk2669 INTEGER :: ipk ! 3rd dimension of the input array2670 INTEGER :: ierr, itaille, ildi, ilei, iilb2671 INTEGER :: ijpj, ijpjm1, ij, iproc2672 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather2673 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather2674 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather2675 ! ! Workspace for message transfers avoiding mpi_allgather2676 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab2677 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk2678 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio2679 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr2680 2681 INTEGER :: istatus(mpi_status_size)2682 INTEGER :: iflag2683 !!----------------------------------------------------------------------2684 !2685 ipk = SIZE( pt3d, 3 )2686 !2687 ALLOCATE( ztab (jpiglo,4,ipk), znorthloc(jpi,4,ipk), zfoldwk(jpi,4,ipk), znorthgloio(jpi,4,ipk,jpni) )2688 ALLOCATE( ztabl(jpi ,4,ipk), ztabr(jpi*jpmaxngh,4,ipk) )2689 2690 ijpj = 42691 ijpjm1 = 32692 !2693 znorthloc(:,:,:) = 0._wp2694 DO jk = 1, ipk2695 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d2696 ij = jj - nlcj + ijpj2697 znorthloc(:,ij,jk) = pt3d(:,jj,jk)2698 END DO2699 END DO2700 !2701 ! ! Build in procs of ncomm_north the znorthgloio2702 itaille = jpi * ipk * ijpj2703 2704 IF ( l_north_nogather ) THEN2705 !2706 ztabr(:,:,:) = 0._wp2707 ztabl(:,:,:) = 0._wp2708 2709 DO jk = 1, ipk2710 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array2711 ij = jj - nlcj + ijpj2712 DO ji = nfsloop, nfeloop2713 ztabl(ji,ij,jk) = pt3d(ji,jj,jk)2714 END DO2715 END DO2716 END DO2717 2718 DO jr = 1,nsndto2719 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN2720 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )2721 ENDIF2722 END DO2723 DO jr = 1,nsndto2724 iproc = nfipproc(isendto(jr),jpnj)2725 IF(iproc /= -1) THEN2726 ilei = nleit (iproc+1)2727 ildi = nldit (iproc+1)2728 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)2729 ENDIF2730 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN2731 CALL mpprecv(5, zfoldwk, itaille, iproc)2732 DO jk = 1, ipk2733 DO jj = 1, ijpj2734 DO ji = ildi, ilei2735 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)2736 END DO2737 END DO2738 END DO2739 ELSE IF( iproc == narea-1 ) THEN2740 DO jk = 1, ipk2741 DO jj = 1, ijpj2742 DO ji = ildi, ilei2743 ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)2744 END DO2745 END DO2746 END DO2747 ENDIF2748 END DO2749 IF (l_isend) THEN2750 DO jr = 1,nsndto2751 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN2752 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )2753 ENDIF2754 END DO2755 ENDIF2756 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition2757 DO jk = 1, ipk2758 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d2759 ij = jj - nlcj + ijpj2760 DO ji= 1, nlci2761 pt3d(ji,jj,jk) = ztabl(ji,ij,jk)2762 END DO2763 END DO2764 END DO2765 !2766 ELSE2767 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &2768 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2769 !2770 ztab(:,:,:) = 0._wp2771 DO jr = 1, ndim_rank_north ! recover the global north array2772 iproc = nrank_north(jr) + 12773 ildi = nldit (iproc)2774 ilei = nleit (iproc)2775 iilb = nimppt(iproc)2776 DO jk = 1, ipk2777 DO jj = 1, ijpj2778 DO ji = ildi, ilei2779 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)2780 END DO2781 END DO2782 END DO2783 END DO2784 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition2785 !2786 DO jk = 1, ipk2787 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d2788 ij = jj - nlcj + ijpj2789 DO ji= 1, nlci2790 pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)2791 END DO2792 END DO2793 END DO2794 !2795 ENDIF2796 !2797 ! The ztab array has been either:2798 ! a. Fully populated by the mpi_allgather operation or2799 ! b. Had the active points for this domain and northern neighbours populated2800 ! by peer to peer exchanges2801 ! Either way the array may be folded by lbc_nfd and the result for the span of2802 ! this domain will be identical.2803 !2804 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )2805 DEALLOCATE( ztabl, ztabr )2806 !2807 END SUBROUTINE mpp_lbc_north_3d2808 2809 2810 SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)2811 !!---------------------------------------------------------------------2812 !! *** routine mpp_lbc_north_2d ***2813 !!2814 !! ** Purpose : Ensure proper north fold horizontal bondary condition2815 !! in mpp configuration in case of jpn1 > 1 (for 2d array )2816 !!2817 !! ** Method : North fold condition and mpp with more than one proc2818 !! in i-direction require a specific treatment. We gather2819 !! the 4 northern lines of the global domain on 1 processor2820 !! and apply lbc north-fold on this sub array. Then we2821 !! scatter the north fold array back to the processors.2822 !!2823 !!----------------------------------------------------------------------2824 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the b.c. is applied2825 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d grid-points2826 ! ! = T , U , V , F or W gridpoints2827 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold2828 !! ! = 1. , the sign is kept2829 INTEGER :: ji, jj, jr2830 INTEGER :: ierr, itaille, ildi, ilei, iilb2831 INTEGER :: ijpj, ijpjm1, ij, iproc2832 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather2833 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather2834 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather2835 ! ! Workspace for message transfers avoiding mpi_allgather2836 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab2837 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: znorthloc, zfoldwk2838 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio2839 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztabl, ztabr2840 INTEGER :: istatus(mpi_status_size)2841 INTEGER :: iflag2842 !!----------------------------------------------------------------------2843 !2844 ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )2845 ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) )2846 !2847 ijpj = 42848 ijpjm1 = 32849 !2850 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d2851 ij = jj - nlcj + ijpj2852 znorthloc(:,ij) = pt2d(:,jj)2853 END DO2854 2855 ! ! Build in procs of ncomm_north the znorthgloio2856 itaille = jpi * ijpj2857 IF ( l_north_nogather ) THEN2858 !2859 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified2860 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange2861 !2862 ztabr(:,:) = 02863 ztabl(:,:) = 02864 2865 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array2866 ij = jj - nlcj + ijpj2867 DO ji = nfsloop, nfeloop2868 ztabl(ji,ij) = pt2d(ji,jj)2869 END DO2870 END DO2871 2872 DO jr = 1,nsndto2873 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN2874 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )2875 ENDIF2876 END DO2877 DO jr = 1,nsndto2878 iproc = nfipproc(isendto(jr),jpnj)2879 IF( iproc /= -1 ) THEN2880 ilei = nleit (iproc+1)2881 ildi = nldit (iproc+1)2882 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)2883 ENDIF2884 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN2885 CALL mpprecv(5, zfoldwk, itaille, iproc)2886 DO jj = 1, ijpj2887 DO ji = ildi, ilei2888 ztabr(iilb+ji,jj) = zfoldwk(ji,jj)2889 END DO2890 END DO2891 ELSEIF( iproc == narea-1 ) THEN2892 DO jj = 1, ijpj2893 DO ji = ildi, ilei2894 ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)2895 END DO2896 END DO2897 ENDIF2898 END DO2899 IF(l_isend) THEN2900 DO jr = 1,nsndto2901 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN2902 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)2903 ENDIF2904 END DO2905 ENDIF2906 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition2907 !2908 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d2909 ij = jj - nlcj + ijpj2910 DO ji = 1, nlci2911 pt2d(ji,jj) = ztabl(ji,ij)2912 END DO2913 END DO2914 !2915 ELSE2916 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &2917 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2918 !2919 ztab(:,:) = 0._wp2920 DO jr = 1, ndim_rank_north ! recover the global north array2921 iproc = nrank_north(jr) + 12922 ildi = nldit (iproc)2923 ilei = nleit (iproc)2924 iilb = nimppt(iproc)2925 DO jj = 1, ijpj2926 DO ji = ildi, ilei2927 ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)2928 END DO2929 END DO2930 END DO2931 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition2932 !2933 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d2934 ij = jj - nlcj + ijpj2935 DO ji = 1, nlci2936 pt2d(ji,jj) = ztab(ji+nimpp-1,ij)2937 END DO2938 END DO2939 !2940 ENDIF2941 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )2942 DEALLOCATE( ztabl, ztabr )2943 !2944 END SUBROUTINE mpp_lbc_north_2d2945 2946 2947 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, kfld )2948 !!---------------------------------------------------------------------2949 !! *** routine mpp_lbc_north_2d ***2950 !!2951 !! ** Purpose : Ensure proper north fold horizontal bondary condition2952 !! in mpp configuration in case of jpn1 > 12953 !! (for multiple 2d arrays )2954 !!2955 !! ** Method : North fold condition and mpp with more than one proc2956 !! in i-direction require a specific treatment. We gather2957 !! the 4 northern lines of the global domain on 1 processor2958 !! and apply lbc north-fold on this sub array. Then we2959 !! scatter the north fold array back to the processors.2960 !!2961 !!----------------------------------------------------------------------2962 TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields2963 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points2964 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold2965 INTEGER , INTENT(in ) :: kfld ! number of variables contained in pt2d2966 !2967 INTEGER :: ji, jj, jr, jk2968 INTEGER :: ierr, itaille, ildi, ilei, iilb2969 INTEGER :: ijpj, ijpjm1, ij, iproc, iflag2970 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather2971 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather2972 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather2973 ! ! Workspace for message transfers avoiding mpi_allgather2974 INTEGER :: istatus(mpi_status_size)2975 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab2976 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk2977 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio2978 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr2979 !!----------------------------------------------------------------------2980 !2981 ALLOCATE( ztab(jpiglo,4,kfld), znorthloc (jpi,4,kfld), &2982 & zfoldwk(jpi,4,kfld), znorthgloio(jpi,4,kfld,jpni), &2983 & ztabl (jpi,4,kfld), ztabr(jpi*jpmaxngh, 4,kfld) )2984 !2985 ijpj = 42986 ijpjm1 = 32987 !2988 2989 DO jk = 1, kfld2990 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable)2991 ij = jj - nlcj + ijpj2992 znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj)2993 END DO2994 END DO2995 ! ! Build in procs of ncomm_north the znorthgloio2996 itaille = jpi * ijpj2997 2998 IF ( l_north_nogather ) THEN2999 !3000 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified3001 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange3002 !3003 ztabr(:,:,:) = 0._wp3004 ztabl(:,:,:) = 0._wp3005 3006 DO jk = 1, kfld3007 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array3008 ij = jj - nlcj + ijpj3009 DO ji = nfsloop, nfeloop3010 ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj)3011 END DO3012 END DO3013 END DO3014 3015 DO jr = 1, nsndto3016 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN3017 CALL mppsend(5, znorthloc, itaille*kfld, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "kfld" times3018 ENDIF3019 END DO3020 DO jr = 1, nsndto3021 iproc = nfipproc(isendto(jr),jpnj)3022 IF( iproc /= -1 ) THEN3023 ilei = nleit (iproc+1)3024 ildi = nldit (iproc+1)3025 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)3026 ENDIF3027 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN3028 CALL mpprecv(5, zfoldwk, itaille*kfld, iproc) ! Buffer expanded "kfld" times3029 DO jk = 1 , kfld3030 DO jj = 1, ijpj3031 DO ji = ildi, ilei3032 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D3033 END DO3034 END DO3035 END DO3036 ELSEIF ( iproc == narea-1 ) THEN3037 DO jk = 1, kfld3038 DO jj = 1, ijpj3039 DO ji = ildi, ilei3040 ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D3041 END DO3042 END DO3043 END DO3044 ENDIF3045 END DO3046 IF( l_isend ) THEN3047 DO jr = 1, nsndto3048 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN3049 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)3050 ENDIF3051 END DO3052 ENDIF3053 !3054 DO ji = 1, kfld ! Loop to manage 3D variables3055 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition3056 END DO3057 !3058 DO jk = 1, kfld3059 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d3060 ij = jj - nlcj + ijpj3061 DO ji = 1, nlci3062 pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D3063 END DO3064 END DO3065 END DO3066 3067 !3068 ELSE3069 !3070 CALL MPI_ALLGATHER( znorthloc , itaille*kfld, MPI_DOUBLE_PRECISION, &3071 & znorthgloio, itaille*kfld, MPI_DOUBLE_PRECISION, ncomm_north, ierr )3072 !3073 ztab(:,:,:) = 0._wp3074 DO jk = 1, kfld3075 DO jr = 1, ndim_rank_north ! recover the global north array3076 iproc = nrank_north(jr) + 13077 ildi = nldit (iproc)3078 ilei = nleit (iproc)3079 iilb = nimppt(iproc)3080 DO jj = 1, ijpj3081 DO ji = ildi, ilei3082 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)3083 END DO3084 END DO3085 END DO3086 END DO3087 3088 DO ji = 1, kfld3089 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition3090 END DO3091 !3092 DO jk = 1, kfld3093 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d3094 ij = jj - nlcj + ijpj3095 DO ji = 1, nlci3096 pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk)3097 END DO3098 END DO3099 END DO3100 !3101 !3102 ENDIF3103 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )3104 DEALLOCATE( ztabl, ztabr )3105 !3106 END SUBROUTINE mpp_lbc_north_2d_multiple3107 3108 3109 1460 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 3110 1461 !!--------------------------------------------------------------------- … … 3165 1516 ! 2. North-Fold boundary conditions 3166 1517 ! ---------------------------------- 3167 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )1518 !!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 3168 1519 3169 1520 ij = jpr2dj … … 3179 1530 ! 3180 1531 END SUBROUTINE mpp_lbc_north_e 3181 3182 3183 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )3184 !!----------------------------------------------------------------------3185 !! *** routine mpp_lnk_bdy_3d ***3186 !!3187 !! ** Purpose : Message passing management3188 !!3189 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries3190 !! between processors following neighboring subdomains.3191 !! domain parameters3192 !! nlci : first dimension of the local subdomain3193 !! nlcj : second dimension of the local subdomain3194 !! nbondi_bdy : mark for "east-west local boundary"3195 !! nbondj_bdy : mark for "north-south local boundary"3196 !! noea : number for local neighboring processors3197 !! nowe : number for local neighboring processors3198 !! noso : number for local neighboring processors3199 !! nono : number for local neighboring processors3200 !!3201 !! ** Action : ptab with update value at its periphery3202 !!3203 !!----------------------------------------------------------------------3204 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied3205 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab grid point3206 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary3207 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set3208 !3209 INTEGER :: ji, jj, jk, jl ! dummy loop indices3210 INTEGER :: ipk ! 3rd dimension of the input array3211 INTEGER :: imigr, iihom, ijhom ! local integers3212 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend3213 REAL(wp) :: zland ! local scalar3214 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend3215 !3216 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north3217 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east3218 !!----------------------------------------------------------------------3219 !3220 ipk = SIZE( ptab, 3 )3221 !3222 ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2), &3223 & zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2) )3224 3225 zland = 0._wp3226 3227 ! 1. standard boundary treatment3228 ! ------------------------------3229 ! ! East-West boundaries3230 ! !* Cyclic3231 IF( nbondi == 2) THEN3232 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN3233 ptab( 1 ,:,:) = ptab(jpim1,:,:)3234 ptab(jpi,:,:) = ptab( 2 ,:,:)3235 ELSE3236 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point3237 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north3238 ENDIF3239 ELSEIF(nbondi == -1) THEN3240 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point3241 ELSEIF(nbondi == 1) THEN3242 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north3243 ENDIF !* closed3244 3245 IF (nbondj == 2 .OR. nbondj == -1) THEN3246 IF( .NOT. cd_type == 'F' ) ptab(:,1:jprecj,:) = zland ! south except F-point3247 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN3248 ptab(:,nlcj-jprecj+1:jpj,:) = zland ! north3249 ENDIF3250 !3251 ! 2. East and west directions exchange3252 ! ------------------------------------3253 ! we play with the neigbours AND the row number because of the periodicity3254 !3255 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions3256 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)3257 iihom = nlci-nreci3258 DO jl = 1, jpreci3259 zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)3260 zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)3261 END DO3262 END SELECT3263 !3264 ! ! Migrations3265 imigr = jpreci * jpj * ipk3266 !3267 SELECT CASE ( nbondi_bdy(ib_bdy) )3268 CASE ( -1 )3269 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )3270 CASE ( 0 )3271 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )3272 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )3273 CASE ( 1 )3274 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )3275 END SELECT3276 !3277 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3278 CASE ( -1 )3279 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )3280 CASE ( 0 )3281 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )3282 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )3283 CASE ( 1 )3284 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )3285 END SELECT3286 !3287 SELECT CASE ( nbondi_bdy(ib_bdy) )3288 CASE ( -1 )3289 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3290 CASE ( 0 )3291 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3292 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)3293 CASE ( 1 )3294 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3295 END SELECT3296 !3297 ! ! Write Dirichlet lateral conditions3298 iihom = nlci-jpreci3299 !3300 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3301 CASE ( -1 )3302 DO jl = 1, jpreci3303 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)3304 END DO3305 CASE ( 0 )3306 DO jl = 1, jpreci3307 ptab( jl,:,:) = zt3we(:,jl,:,2)3308 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)3309 END DO3310 CASE ( 1 )3311 DO jl = 1, jpreci3312 ptab( jl,:,:) = zt3we(:,jl,:,2)3313 END DO3314 END SELECT3315 3316 ! 3. North and south directions3317 ! -----------------------------3318 ! always closed : we play only with the neigbours3319 !3320 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions3321 ijhom = nlcj-nrecj3322 DO jl = 1, jprecj3323 zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)3324 zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)3325 END DO3326 ENDIF3327 !3328 ! ! Migrations3329 imigr = jprecj * jpi * ipk3330 !3331 SELECT CASE ( nbondj_bdy(ib_bdy) )3332 CASE ( -1 )3333 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )3334 CASE ( 0 )3335 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )3336 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )3337 CASE ( 1 )3338 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )3339 END SELECT3340 !3341 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3342 CASE ( -1 )3343 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )3344 CASE ( 0 )3345 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )3346 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )3347 CASE ( 1 )3348 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )3349 END SELECT3350 !3351 SELECT CASE ( nbondj_bdy(ib_bdy) )3352 CASE ( -1 )3353 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3354 CASE ( 0 )3355 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3356 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)3357 CASE ( 1 )3358 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3359 END SELECT3360 !3361 ! ! Write Dirichlet lateral conditions3362 ijhom = nlcj-jprecj3363 !3364 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3365 CASE ( -1 )3366 DO jl = 1, jprecj3367 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)3368 END DO3369 CASE ( 0 )3370 DO jl = 1, jprecj3371 ptab(:,jl ,:) = zt3sn(:,jl,:,2)3372 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)3373 END DO3374 CASE ( 1 )3375 DO jl = 1, jprecj3376 ptab(:,jl,:) = zt3sn(:,jl,:,2)3377 END DO3378 END SELECT3379 3380 ! 4. north fold treatment3381 ! -----------------------3382 !3383 IF( npolj /= 0) THEN3384 !3385 SELECT CASE ( jpni )3386 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp3387 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.3388 END SELECT3389 !3390 ENDIF3391 !3392 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )3393 !3394 END SUBROUTINE mpp_lnk_bdy_3d3395 3396 3397 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )3398 !!----------------------------------------------------------------------3399 !! *** routine mpp_lnk_bdy_2d ***3400 !!3401 !! ** Purpose : Message passing management3402 !!3403 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries3404 !! between processors following neighboring subdomains.3405 !! domain parameters3406 !! nlci : first dimension of the local subdomain3407 !! nlcj : second dimension of the local subdomain3408 !! nbondi_bdy : mark for "east-west local boundary"3409 !! nbondj_bdy : mark for "north-south local boundary"3410 !! noea : number for local neighboring processors3411 !! nowe : number for local neighboring processors3412 !! noso : number for local neighboring processors3413 !! nono : number for local neighboring processors3414 !!3415 !! ** Action : ptab with update value at its periphery3416 !!3417 !!----------------------------------------------------------------------3418 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied3419 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points3420 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary3421 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set3422 !3423 INTEGER :: ji, jj, jl ! dummy loop indices3424 INTEGER :: imigr, iihom, ijhom ! local integers3425 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend3426 REAL(wp) :: zland3427 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend3428 !3429 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north3430 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east3431 !!----------------------------------------------------------------------3432 3433 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &3434 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )3435 3436 zland = 0._wp3437 3438 ! 1. standard boundary treatment3439 ! ------------------------------3440 ! ! East-West boundaries3441 ! !* Cyclic3442 IF( nbondi == 2 ) THEN3443 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN3444 ptab( 1 ,:) = ptab(jpim1,:)3445 ptab(jpi,:) = ptab( 2 ,:)3446 ELSE3447 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point3448 ptab(nlci-jpreci+1:jpi ,:) = zland ! north3449 ENDIF3450 ELSEIF(nbondi == -1) THEN3451 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point3452 ELSEIF(nbondi == 1) THEN3453 ptab(nlci-jpreci+1:jpi ,:) = zland ! north3454 ENDIF3455 ! !* closed3456 IF( nbondj == 2 .OR. nbondj == -1 ) THEN3457 IF( .NOT.cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point3458 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN3459 ptab(:,nlcj-jprecj+1:jpj ) = zland ! north3460 ENDIF3461 !3462 ! 2. East and west directions exchange3463 ! ------------------------------------3464 ! we play with the neigbours AND the row number because of the periodicity3465 !3466 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions3467 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)3468 iihom = nlci-nreci3469 DO jl = 1, jpreci3470 zt2ew(:,jl,1) = ptab(jpreci+jl,:)3471 zt2we(:,jl,1) = ptab(iihom +jl,:)3472 END DO3473 END SELECT3474 !3475 ! ! Migrations3476 imigr = jpreci * jpj3477 !3478 SELECT CASE ( nbondi_bdy(ib_bdy) )3479 CASE ( -1 )3480 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )3481 CASE ( 0 )3482 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )3483 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )3484 CASE ( 1 )3485 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )3486 END SELECT3487 !3488 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3489 CASE ( -1 )3490 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )3491 CASE ( 0 )3492 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )3493 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )3494 CASE ( 1 )3495 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )3496 END SELECT3497 !3498 SELECT CASE ( nbondi_bdy(ib_bdy) )3499 CASE ( -1 )3500 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3501 CASE ( 0 )3502 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3503 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )3504 CASE ( 1 )3505 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3506 END SELECT3507 !3508 ! ! Write Dirichlet lateral conditions3509 iihom = nlci-jpreci3510 !3511 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3512 CASE ( -1 )3513 DO jl = 1, jpreci3514 ptab(iihom+jl,:) = zt2ew(:,jl,2)3515 END DO3516 CASE ( 0 )3517 DO jl = 1, jpreci3518 ptab(jl ,:) = zt2we(:,jl,2)3519 ptab(iihom+jl,:) = zt2ew(:,jl,2)3520 END DO3521 CASE ( 1 )3522 DO jl = 1, jpreci3523 ptab(jl ,:) = zt2we(:,jl,2)3524 END DO3525 END SELECT3526 3527 3528 ! 3. North and south directions3529 ! -----------------------------3530 ! always closed : we play only with the neigbours3531 !3532 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions3533 ijhom = nlcj-nrecj3534 DO jl = 1, jprecj3535 zt2sn(:,jl,1) = ptab(:,ijhom +jl)3536 zt2ns(:,jl,1) = ptab(:,jprecj+jl)3537 END DO3538 ENDIF3539 !3540 ! ! Migrations3541 imigr = jprecj * jpi3542 !3543 SELECT CASE ( nbondj_bdy(ib_bdy) )3544 CASE ( -1 )3545 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )3546 CASE ( 0 )3547 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )3548 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )3549 CASE ( 1 )3550 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )3551 END SELECT3552 !3553 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3554 CASE ( -1 )3555 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )3556 CASE ( 0 )3557 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )3558 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )3559 CASE ( 1 )3560 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )3561 END SELECT3562 !3563 SELECT CASE ( nbondj_bdy(ib_bdy) )3564 CASE ( -1 )3565 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )3566 CASE ( 0 )3567 IF(l_isend) CALL mpi_wait (ml_req1, ml_stat, ml_err )3568 IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err )3569 CASE ( 1 )3570 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )3571 END SELECT3572 !3573 ! ! Write Dirichlet lateral conditions3574 ijhom = nlcj-jprecj3575 !3576 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3577 CASE ( -1 )3578 DO jl = 1, jprecj3579 ptab(:,ijhom+jl) = zt2ns(:,jl,2)3580 END DO3581 CASE ( 0 )3582 DO jl = 1, jprecj3583 ptab(:,jl ) = zt2sn(:,jl,2)3584 ptab(:,ijhom+jl) = zt2ns(:,jl,2)3585 END DO3586 CASE ( 1 )3587 DO jl = 1, jprecj3588 ptab(:,jl) = zt2sn(:,jl,2)3589 END DO3590 END SELECT3591 3592 ! 4. north fold treatment3593 ! -----------------------3594 !3595 IF( npolj /= 0) THEN3596 !3597 SELECT CASE ( jpni )3598 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp3599 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.3600 END SELECT3601 !3602 ENDIF3603 !3604 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )3605 !3606 END SUBROUTINE mpp_lnk_bdy_2d3607 1532 3608 1533 … … 3666 1591 END SUBROUTINE mpi_init_opa 3667 1592 3668 SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 1593 1594 SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype ) 3669 1595 !!--------------------------------------------------------------------- 3670 1596 !! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD … … 3680 1606 INTEGER :: ji, ztmp ! local scalar 3681 1607 !!--------------------------------------------------------------------- 3682 1608 ! 3683 1609 ztmp = itype ! avoid compilation warning 3684 1610 ! 3685 1611 DO ji=1,ilen 3686 1612 ! Compute ydda + yddb using Knuth's trick. … … 3693 1619 yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp ) 3694 1620 END DO 3695 1621 ! 3696 1622 END SUBROUTINE DDPDD_MPI 3697 1623 … … 3763 1689 END DO 3764 1690 3765 3766 1691 ! 2. North-Fold boundary conditions 3767 1692 ! ---------------------------------- 3768 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )1693 !!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 3769 1694 3770 1695 ij = ipr2dj … … 3809 1734 ! 3810 1735 INTEGER :: jl ! dummy loop indices 3811 INTEGER :: imigr, iihom, ijhom ! temporaryintegers3812 INTEGER :: ipreci, iprecj ! temporary integers1736 INTEGER :: imigr, iihom, ijhom ! local integers 1737 INTEGER :: ipreci, iprecj ! - - 3813 1738 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3814 1739 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3815 1740 !! 3816 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 3817 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 3818 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 3819 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 1741 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns, r2dsn 1742 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe, r2dew 3820 1743 !!---------------------------------------------------------------------- 3821 1744 … … 3845 1768 ! 3846 1769 SELECT CASE ( jpni ) 3847 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )3848 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj )1770 !!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 1771 !!gm ERROR CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj ) 3849 1772 END SELECT 3850 1773 ! -
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90
r7864 r8186 137 137 END DO 138 138 END DO 139 CALL lbc_lnk( usd(:,:,:), 'U', vsd(:,:,:), 'V', -1. ) 139 !!gm CALL lbc_lnk( usd(:,:,:), 'U', vsd(:,:,:), 'V', -1. ) 140 CALL lbc_lnk( usd(:,:,:), 'U', -1. ) 141 CALL lbc_lnk( vsd(:,:,:), 'V', -1. ) 142 143 140 144 ! 141 145 ! !== vertical Stokes Drift 3D velocity ==!
Note: See TracChangeset
for help on using the changeset viewer.