Changeset 7904 for branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC
- Timestamp:
- 2017-04-13T09:10:07+02:00 (7 years ago)
- Location:
- branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 6 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90
r7646 r7904 126 126 INTEGER :: numoni = -1 !: logical unit for Output Namelist Ice 127 127 INTEGER :: numevo_ice = -1 !: logical unit for ice variables (temp. evolution) 128 INTEGER :: num sol = -1 !: logical unit for solverstatistics128 INTEGER :: numrun = -1 !: logical unit for run statistics 129 129 INTEGER :: numdct_in = -1 !: logical unit for transports computing 130 130 INTEGER :: numdct_vol = -1 !: logical unit for voulume transports output -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r6493 r7904 2 2 !!====================================================================== 3 3 !! *** MODULE lbclnk *** 4 !! Ocean: lateral boundary conditions4 !! NEMO : lateral boundary conditions 5 5 !!===================================================================== 6 6 !! History : OPA ! 1997-06 (G. Madec) Original code … … 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 !! 4.0 ! 2017-03 (G. Madec) automatique allocation of array size (use with any 3rd dim size) 13 !! - ! 2017-04 (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather) 12 14 !!---------------------------------------------------------------------- 13 15 #if defined key_mpp_mpi … … 15 17 !! 'key_mpp_mpi' MPI massively parallel processing library 16 18 !!---------------------------------------------------------------------- 17 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 18 !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp 19 !! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 20 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 19 !! define the generic interfaces of lib_mpp routines 20 !!---------------------------------------------------------------------- 21 !! 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_mpp 23 !! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 24 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 21 25 !!---------------------------------------------------------------------- 22 26 USE lib_mpp ! distributed memory computing library … … 46 50 END INTERFACE 47 51 48 PUBLIC lbc_lnk ! ocean lateral boundary conditions49 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions50 PUBLIC lbc_sum 51 PUBLIC lbc_lnk_e ! 52 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 53 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 54 PUBLIC lbc_sum ! sum across processors 55 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions 52 56 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 53 PUBLIC lbc_lnk_icb ! 54 55 !!---------------------------------------------------------------------- 56 !! NEMO/OPA 3.3 , NEMO Consortium (2010)57 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 58 59 !!---------------------------------------------------------------------- 60 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 57 61 !! $Id$ 58 62 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 61 65 !!---------------------------------------------------------------------- 62 66 !! Default option shared memory computing 67 !!---------------------------------------------------------------------- 68 !! routines setting the appropriate values 69 !! on first and last row and column of the global domain 63 70 !!---------------------------------------------------------------------- 64 71 !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d … … 70 77 !! lbc_bdy_lnk : set the lateral BDY boundary condition 71 78 !!---------------------------------------------------------------------- 72 USE oce 73 USE dom_oce 74 USE in_out_manager 75 USE lbcnfd 79 USE oce ! ocean dynamics and tracers 80 USE dom_oce ! ocean space and time domain 81 USE in_out_manager ! I/O manager 82 USE lbcnfd ! north fold 76 83 77 84 IMPLICIT NONE … … 85 92 MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 86 93 END INTERFACE 87 94 ! 88 95 INTERFACE lbc_lnk_e 89 96 MODULE PROCEDURE lbc_lnk_2d_e … … 93 100 MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 94 101 END INTERFACE 95 102 ! 96 103 INTERFACE lbc_bdy_lnk 97 104 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 105 112 REAL , DIMENSION (:,:), POINTER :: pt2d 106 113 END TYPE arrayptr 114 ! 107 115 PUBLIC arrayptr 108 116 109 117 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 110 118 PUBLIC lbc_sum ! ocean/ice lateral boundary conditions (sum of the overlap region) 111 PUBLIC lbc_lnk_e ! 112 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions119 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions 120 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 113 121 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 114 PUBLIC lbc_lnk_icb ! 122 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 115 123 116 124 !!---------------------------------------------------------------------- 117 !! NEMO/OPA 3.7 , NEMO Consortium (2015)125 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 118 126 !! $Id$ 119 127 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 125 133 !! 'key_c1d' 1D configuration 126 134 !!---------------------------------------------------------------------- 127 128 SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 129 !!--------------------------------------------------------------------- 130 !! *** ROUTINE lbc_lnk_3d_gather *** 131 !! 132 !! ** Purpose : set lateral boundary conditions on two 3D arrays (C1D case) 133 !! 134 !! ** Method : call lbc_lnk_3d on pt3d1 and pt3d2 135 !!---------------------------------------------------------------------- 136 CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! nature of pt3d grid-points 137 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied 138 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 139 !!---------------------------------------------------------------------- 140 ! 141 CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 142 CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 143 ! 144 END SUBROUTINE lbc_lnk_3d_gather 145 135 !! central point value replicated over the 8 surrounding points 136 !!---------------------------------------------------------------------- 146 137 147 138 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) … … 153 144 !! ** Method : 1D case, the central water column is set everywhere 154 145 !!---------------------------------------------------------------------- 155 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points156 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied157 REAL(wp) , INTENT(in ) :: psgn ! control of the sign158 CHARACTER(len=3) 159 REAL(wp) 146 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 147 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 148 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 149 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 150 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 160 151 ! 161 152 INTEGER :: jk ! dummy loop index … … 163 154 !!---------------------------------------------------------------------- 164 155 ! 165 DO jk = 1, jpk156 DO jk = 1, SIZE( pt3d, 3 ) 166 157 ztab = pt3d(2,2,jk) 167 158 pt3d(:,:,jk) = ztab … … 179 170 !! ** Method : 1D case, the central water column is set everywhere 180 171 !!---------------------------------------------------------------------- 172 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 181 173 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 182 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 183 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 174 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 184 175 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 185 176 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) … … 193 184 END SUBROUTINE lbc_lnk_2d 194 185 195 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields )196 !!197 INTEGER :: num_fields198 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array199 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points200 ! ! = T , U , V , F , W and I points201 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary202 ! ! = 1. , the sign is kept203 !204 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES205 !206 DO ii = 1, num_fields207 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) )208 END DO209 !210 END SUBROUTINE lbc_lnk_2d_multiple211 212 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC &213 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF &214 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval)215 !!---------------------------------------------------------------------216 ! Second 2D array on which the boundary condition is applied217 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA218 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE219 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI220 ! define the nature of ptab array grid-points221 CHARACTER(len=1) , INTENT(in ) :: cd_typeA222 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE223 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI224 ! =-1 the sign change across the north fold boundary225 REAL(wp) , INTENT(in ) :: psgnA226 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE227 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI228 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only229 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries)230 !!231 !!---------------------------------------------------------------------232 233 !!The first array234 CALL lbc_lnk( pt2dA, cd_typeA, psgnA )235 236 !! Look if more arrays to process237 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )238 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )239 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )240 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )241 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )242 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )243 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )244 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )245 246 END SUBROUTINE lbc_lnk_2d_9247 248 249 250 251 252 186 #else 253 187 !!---------------------------------------------------------------------- 254 188 !! Default option 3D shared memory computing 255 189 !!---------------------------------------------------------------------- 256 257 SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 258 !!--------------------------------------------------------------------- 259 !! *** ROUTINE lbc_lnk_3d_gather *** 260 !! 261 !! ** Purpose : set lateral boundary conditions on two 3D arrays (non mpp case) 190 !! routines setting land point, or east-west cyclic, 191 !! or north-south cyclic, or north fold values 192 !! on first and last row and column of the global domain 193 !!---------------------------------------------------------------------- 194 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) 262 200 !! 263 201 !! ** Method : psign = -1 : change the sign across the north fold … … 267 205 !! for closed boundaries. 268 206 !!---------------------------------------------------------------------- 269 CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! nature of pt3d grid-points 270 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied 271 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 272 !!---------------------------------------------------------------------- 273 ! 274 CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 275 CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 276 ! 277 END SUBROUTINE lbc_lnk_3d_gather 278 279 280 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 281 !!--------------------------------------------------------------------- 282 !! *** ROUTINE lbc_lnk_3d *** 283 !! 284 !! ** Purpose : set lateral boundary conditions on a 3D 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,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 294 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 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 !! 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 ! 298 213 REAL(wp) :: zland 299 214 !!---------------------------------------------------------------------- 300 215 ! 301 216 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 302 217 ELSE ; zland = 0._wp 303 218 ENDIF 304 305 219 ! 306 220 IF( PRESENT( cd_mpp ) ) THEN 307 221 ! only fill the overlap area and extra allows … … 378 292 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 379 293 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 380 REAL(wp) , INTENT(in ) :: psgn ! control of the sign294 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 381 295 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 382 296 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) … … 448 362 END SUBROUTINE lbc_lnk_2d 449 363 450 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 451 !! 452 INTEGER :: num_fields 453 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 454 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 455 ! ! = T , U , V , F , W and I points 456 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 457 ! ! = 1. , the sign is kept 458 ! 459 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 460 ! 461 DO ii = 1, num_fields 462 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 364 #endif 365 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) ) 463 401 END DO 464 402 ! 465 403 END SUBROUTINE lbc_lnk_2d_multiple 466 404 467 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 468 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 469 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 470 !!--------------------------------------------------------------------- 471 ! Second 2D array on which the boundary condition is applied 472 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 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 473 412 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 474 413 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 475 ! define the nature of ptab array grid-points 476 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 414 CHARACTER(len=1) , INTENT(in ) :: cd_typeA ! nature of pt2D. array grid-points 477 415 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 478 416 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 479 ! =-1 the sign change across the north fold boundary 480 REAL(wp) , INTENT(in ) :: psgnA 417 REAL(wp) , INTENT(in ) :: psgnA ! sign used across the north fold 481 418 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 482 419 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI … … 485 422 !! 486 423 !!--------------------------------------------------------------------- 487 488 !!The first array 489 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 490 491 !! Look if more arrays to process 492 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 493 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 494 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 495 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 496 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 497 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 498 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 499 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 500 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 ! 501 436 END SUBROUTINE lbc_lnk_2d_9 437 438 439 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 used 444 !! to maintain the same interface with regards to the mpp case 445 !!---------------------------------------------------------------------- 446 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 447 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 448 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 449 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 450 !!---------------------------------------------------------------------- 451 ! 452 CALL lbc_lnk_3d( pt3d, cd_type, psgn) 453 ! 454 END SUBROUTINE lbc_bdy_lnk_3d 455 456 457 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 used 462 !! to maintain the same interface with regards to the mpp case 463 !!---------------------------------------------------------------------- 464 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied 465 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 466 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 467 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 468 !!---------------------------------------------------------------------- 469 ! 470 CALL lbc_lnk_2d( pt2d, cd_type, psgn) 471 ! 472 END SUBROUTINE lbc_bdy_lnk_2d 473 474 475 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 case 481 !!---------------------------------------------------------------------- 482 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 483 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 484 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 485 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp) 486 !!---------------------------------------------------------------------- 487 ! 488 CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 489 ! 490 END SUBROUTINE lbc_lnk_2d_e 491 502 492 503 493 SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) … … 513 503 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 514 504 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 515 REAL(wp) , INTENT(in ) :: psgn ! control of the sign505 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 516 506 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 517 507 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) … … 519 509 REAL(wp) :: zland 520 510 !!---------------------------------------------------------------------- 521 511 ! 522 512 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 523 513 ELSE ; zland = 0._wp 524 514 ENDIF 525 515 ! 526 516 IF (PRESENT(cd_mpp)) THEN 527 517 ! only fill the overlap area and extra allows … … 553 543 ! 554 544 END IF 555 545 ! 556 546 END SUBROUTINE 547 557 548 558 549 SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) … … 566 557 !! this line, nothing is done along the north fold. 567 558 !!---------------------------------------------------------------------- 568 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points569 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied570 REAL(wp) , INTENT(in ) :: psgn ! control of the sign571 CHARACTER(len=3) 572 REAL(wp) 573 ! !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 ! 574 565 REAL(wp) :: zland 575 566 !!---------------------------------------------------------------------- 576 567 ! 577 568 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 578 569 ELSE ; zland = 0._wp 579 570 ENDIF 580 581 571 ! 582 572 IF( PRESENT( cd_mpp ) ) THEN 583 573 ! only fill the overlap area and extra allows … … 591 581 pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 592 582 pt3d( 2 ,:,:) = pt3d( 2 ,:,:) + pt3d(jpi,:,:) 593 pt3d( 1 ,:,:) = 0. 0_wp ! all points594 pt3d(jpi,:,:) = 0. 0_wp583 pt3d( 1 ,:,:) = 0._wp 584 pt3d(jpi,:,:) = 0._wp 595 585 ! 596 586 CASE DEFAULT !** East closed -- West closed … … 609 599 ! 610 600 END IF 601 ! 611 602 END SUBROUTINE 612 613 614 #endif615 616 SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy )617 !!---------------------------------------------------------------------618 !! *** ROUTINE lbc_bdy_lnk ***619 !!620 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used621 !! to maintain the same interface with regards to the mpp case622 !!623 !!----------------------------------------------------------------------624 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points625 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied626 REAL(wp) , INTENT(in ) :: psgn ! control of the sign627 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set628 !!----------------------------------------------------------------------629 !630 CALL lbc_lnk_3d( pt3d, cd_type, psgn)631 !632 END SUBROUTINE lbc_bdy_lnk_3d633 634 635 SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy )636 !!---------------------------------------------------------------------637 !! *** ROUTINE lbc_bdy_lnk ***638 !!639 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used640 !! to maintain the same interface with regards to the mpp case641 !!642 !!----------------------------------------------------------------------643 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points644 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied645 REAL(wp) , INTENT(in ) :: psgn ! control of the sign646 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set647 !!----------------------------------------------------------------------648 !649 CALL lbc_lnk_2d( pt2d, cd_type, psgn)650 !651 END SUBROUTINE lbc_bdy_lnk_2d652 653 654 SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )655 !!---------------------------------------------------------------------656 !! *** ROUTINE lbc_lnk_2d ***657 !!658 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case)659 !! special dummy routine to allow for use of halo indexing in mpp case660 !!661 !! ** Method : psign = -1 : change the sign across the north fold662 !! = 1 : no change of the sign across the north fold663 !! = 0 : no change of the sign across the north fold and664 !! strict positivity preserved: use inner row/column665 !! for closed boundaries.666 !!----------------------------------------------------------------------667 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points668 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied669 REAL(wp) , INTENT(in ) :: psgn ! control of the sign670 INTEGER , INTENT(in ) :: jpri ! size of extra halo (not needed in non-mpp)671 INTEGER , INTENT(in ) :: jprj ! size of extra halo (not needed in non-mpp)672 !!----------------------------------------------------------------------673 !674 CALL lbc_lnk_2d( pt2d, cd_type, psgn )675 !676 END SUBROUTINE lbc_lnk_2d_e677 603 678 604 #endif -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r7646 r7904 5 5 !!====================================================================== 6 6 !! History : 3.2 ! 2009-03 (R. Benshila) Original code 7 !! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization 7 !! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization 8 !! 4.0 ! 2017-04 (G. Madec) automatique allocation of array argument (use any 3rd dimension) 8 9 !!---------------------------------------------------------------------- 9 10 … … 12 13 !! lbc_nfd_3d : lateral boundary condition: North fold treatment for a 3D arrays (lbc_nfd) 13 14 !! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd) 14 !! mpp_lbc_nfd_3d 15 !! mpp_lbc_nfd_2d 15 !! 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 16 17 !!---------------------------------------------------------------------- 17 18 USE dom_oce ! ocean space and time domain … … 54 55 !! ** Action : pt3d with updated values along the north fold 55 56 !!---------------------------------------------------------------------- 56 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points57 ! ! = T , U , V , F , W points58 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change59 ! ! = -1. , the sign is changed if north fold boundary60 ! ! = 1. , the sign is kept if north fold boundary61 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 62 60 ! 63 61 INTEGER :: ji, jk 64 62 INTEGER :: ijt, iju, ijpj, ijpjm1 65 63 !!---------------------------------------------------------------------- 66 64 ! 67 65 SELECT CASE ( jpni ) 68 66 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction … … 71 69 ijpjm1 = ijpj-1 72 70 73 DO jk = 1, jpk71 DO jk = 1, SIZE( pt3d, 3 ) 74 72 ! 75 73 SELECT CASE ( npolj ) … … 155 153 SELECT CASE ( cd_type) 156 154 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 157 pt3d(:, 1 ,jk) = 0. e0158 pt3d(:,ijpj,jk) = 0. e0155 pt3d(:, 1 ,jk) = 0._wp 156 pt3d(:,ijpj,jk) = 0._wp 159 157 CASE ( 'F' ) ! F-point 160 pt3d(:,ijpj,jk) = 0. e0158 pt3d(:,ijpj,jk) = 0._wp 161 159 END SELECT 162 160 ! … … 179 177 !! ** Action : pt2d with updated values along the north fold 180 178 !!---------------------------------------------------------------------- 181 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points182 ! ! = T , U , V , F , W points183 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change184 ! ! = -1. , the sign is changed if north fold boundary185 ! ! = 1. , the sign is kept if north fold boundary186 179 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-point 181 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 187 182 INTEGER , OPTIONAL , INTENT(in ) :: pr2dj ! number of additional halos 188 183 ! … … 265 260 END DO 266 261 END DO 267 CASE ( 'J' ) ! first ice U-V point268 DO jl =0, ipr2dj269 pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)270 DO ji = 3, jpiglo271 iju = jpiglo - ji + 3272 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)273 END DO274 END DO275 CASE ( 'K' ) ! second ice U-V point276 DO jl =0, ipr2dj277 pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)278 DO ji = 3, jpiglo279 iju = jpiglo - ji + 3280 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)281 END DO282 END DO283 262 END SELECT 284 263 ! … … 325 304 END DO 326 305 CASE ( 'I' ) ! ice U-V point (I-point) 327 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0. e0306 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp 328 307 DO jl = 0, ipr2dj 329 308 DO ji = 2 , jpiglo-1 … … 332 311 END DO 333 312 END DO 334 CASE ( 'J' ) ! first ice U-V point335 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0336 DO jl = 0, ipr2dj337 DO ji = 2 , jpiglo-1338 ijt = jpiglo - ji + 2339 pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl)340 END DO341 END DO342 CASE ( 'K' ) ! second ice U-V point343 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0344 DO jl = 0, ipr2dj345 DO ji = 2 , jpiglo-1346 ijt = jpiglo - ji + 2347 pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl)348 END DO349 END DO350 313 END SELECT 351 314 ! … … 354 317 SELECT CASE ( cd_type) 355 318 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 356 pt2d(:, 1:1-ipr2dj ) = 0. e0357 pt2d(:,ijpj:ijpj+ipr2dj) = 0. e0319 pt2d(:, 1:1-ipr2dj ) = 0._wp 320 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 358 321 CASE ( 'F' ) ! F-point 359 pt2d(:,ijpj:ijpj+ipr2dj) = 0. e0322 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 360 323 CASE ( 'I' ) ! ice U-V point 361 pt2d(:, 1:1-ipr2dj ) = 0.e0 362 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 363 CASE ( 'J' ) ! first ice U-V point 364 pt2d(:, 1:1-ipr2dj ) = 0.e0 365 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 366 CASE ( 'K' ) ! second ice U-V point 367 pt2d(:, 1:1-ipr2dj ) = 0.e0 368 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 324 pt2d(:, 1:1-ipr2dj ) = 0._wp 325 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 369 326 END SELECT 370 327 ! … … 385 342 !! ** Action : pt3d with updated values along the north fold 386 343 !!---------------------------------------------------------------------- 387 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points388 ! ! = T , U , V , F , W points389 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change390 ! ! = -1. , the sign is changed if north fold boundary391 ! ! = 1. , the sign is kept if north fold boundary392 344 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3dl ! 3D array on which the boundary condition is applied 393 345 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pt3dr ! 3D array on which the boundary condition is applied 394 ! 395 INTEGER :: ji, jk 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 396 351 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 397 352 !!---------------------------------------------------------------------- 353 ! 354 ipk = SIZE( pt3dl, 3 ) 398 355 ! 399 356 SELECT CASE ( jpni ) … … 402 359 END SELECT 403 360 ijpjm1 = ijpj-1 404 405 406 407 408 409 410 361 ! 362 ! 363 SELECT CASE ( npolj ) 364 ! 365 CASE ( 3 , 4 ) ! * North fold T-point pivot 366 ! 367 SELECT CASE ( cd_type ) 411 368 CASE ( 'T' , 'W' ) ! T-, W-point 412 IF (nimpp .ne. 1) THEN 413 startloop = 1 414 ELSE 415 startloop = 2 416 ENDIF 417 418 DO jk = 1, jpk 369 IF ( nimpp /= 1 ) THEN ; startloop = 1 370 ELSE ; startloop = 2 371 ENDIF 372 ! 373 DO jk = 1, ipk 419 374 DO ji = startloop, nlci 420 375 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 … … 426 381 END DO 427 382 428 IF( nimpp .ge. (jpiglo/2+1)) THEN383 IF( nimpp >= jpiglo/2+1 ) THEN 429 384 startloop = 1 430 ELSEIF( ((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN385 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 431 386 startloop = jpiglo/2+1 - nimpp + 1 432 387 ELSE 433 388 startloop = nlci + 1 434 389 ENDIF 435 IF(startloop .le.nlci) THEN436 DO jk = 1, jpk390 IF(startloop <= nlci) THEN 391 DO jk = 1, ipk 437 392 DO ji = startloop, nlci 438 393 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 439 394 jia = ji + nimpp - 1 440 395 ijta = jpiglo - jia + 2 441 IF( (ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN396 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 442 397 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 443 398 ELSE … … 447 402 END DO 448 403 ENDIF 449 450 404 ! 451 405 CASE ( 'U' ) ! U-point 452 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN406 IF( nimpp + nlci - 1 /= jpiglo ) THEN 453 407 endloop = nlci 454 408 ELSE 455 409 endloop = nlci - 1 456 410 ENDIF 457 DO jk = 1, jpk411 DO jk = 1, ipk 458 412 DO ji = 1, endloop 459 413 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 … … 467 421 ENDIF 468 422 END DO 469 470 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN423 ! 424 IF( nimpp + nlci - 1 /= jpiglo ) THEN 471 425 endloop = nlci 472 426 ELSE 473 427 endloop = nlci - 1 474 428 ENDIF 475 IF( nimpp .ge. (jpiglo/2)) THEN429 IF( nimpp >= jpiglo/2 ) THEN 476 430 startloop = 1 477 ELSEIF( ((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN431 ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 478 432 startloop = jpiglo/2 - nimpp + 1 479 433 ELSE 480 434 startloop = endloop + 1 481 435 ENDIF 482 IF (startloop .le. endloop) THEN483 DO jk = 1, jpk436 IF( startloop <= endloop ) THEN 437 DO jk = 1, ipk 484 438 DO ji = startloop, endloop 485 439 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 486 440 jia = ji + nimpp - 1 487 441 ijua = jpiglo - jia + 1 488 IF( (ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN442 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 489 443 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 490 444 ELSE … … 494 448 END DO 495 449 ENDIF 496 450 ! 497 451 CASE ( 'V' ) ! V-point 498 IF (nimpp .ne. 1) THEN452 IF( nimpp /= 1 ) THEN 499 453 startloop = 1 500 454 ELSE 501 455 startloop = 2 502 456 ENDIF 503 DO jk = 1, jpk457 DO jk = 1, ipk 504 458 DO ji = startloop, nlci 505 459 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 … … 512 466 END DO 513 467 CASE ( 'F' ) ! F-point 514 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN468 IF( nimpp + nlci - 1 /= jpiglo ) THEN 515 469 endloop = nlci 516 470 ELSE 517 471 endloop = nlci - 1 518 472 ENDIF 519 DO jk = 1, jpk473 DO jk = 1, ipk 520 474 DO ji = 1, endloop 521 475 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 … … 530 484 ENDIF 531 485 END DO 532 END SELECT 533 ! 534 535 CASE ( 5 , 6 ) ! * North fold F-point pivot 536 ! 537 SELECT CASE ( cd_type ) 486 END SELECT 487 ! 488 CASE ( 5 , 6 ) ! * North fold F-point pivot 489 ! 490 SELECT CASE ( cd_type ) 538 491 CASE ( 'T' , 'W' ) ! T-, W-point 539 DO jk = 1, jpk492 DO jk = 1, ipk 540 493 DO ji = 1, nlci 541 494 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 … … 543 496 END DO 544 497 END DO 545 498 ! 546 499 CASE ( 'U' ) ! U-point 547 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN500 IF( nimpp + nlci - 1 /= jpiglo ) THEN 548 501 endloop = nlci 549 502 ELSE 550 503 endloop = nlci - 1 551 504 ENDIF 552 DO jk = 1, jpk505 DO jk = 1, ipk 553 506 DO ji = 1, endloop 554 507 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 … … 559 512 ENDIF 560 513 END DO 561 514 ! 562 515 CASE ( 'V' ) ! V-point 563 DO jk = 1, jpk516 DO jk = 1, ipk 564 517 DO ji = 1, nlci 565 518 ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 … … 567 520 END DO 568 521 END DO 569 570 IF( nimpp .ge. (jpiglo/2+1)) THEN522 ! 523 IF( nimpp >= jpiglo/2+1 ) THEN 571 524 startloop = 1 572 ELSEIF( ((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN525 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 573 526 startloop = jpiglo/2+1 - nimpp + 1 574 527 ELSE 575 528 startloop = nlci + 1 576 529 ENDIF 577 IF( startloop .le. nlci) THEN578 DO jk = 1, jpk530 IF( startloop <= nlci ) THEN 531 DO jk = 1, ipk 579 532 DO ji = startloop, nlci 580 533 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 … … 583 536 END DO 584 537 ENDIF 585 538 ! 586 539 CASE ( 'F' ) ! F-point 587 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN540 IF( nimpp + nlci - 1 /= jpiglo ) THEN 588 541 endloop = nlci 589 542 ELSE 590 543 endloop = nlci - 1 591 544 ENDIF 592 DO jk = 1, jpk545 DO jk = 1, ipk 593 546 DO ji = 1, endloop 594 547 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 … … 599 552 ENDIF 600 553 END DO 601 602 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN554 ! 555 IF( nimpp + nlci - 1 /= jpiglo ) THEN 603 556 endloop = nlci 604 557 ELSE 605 558 endloop = nlci - 1 606 559 ENDIF 607 IF( nimpp .ge. (jpiglo/2+1)) THEN560 IF( nimpp >= jpiglo/2+1 ) THEN 608 561 startloop = 1 609 ELSEIF( ((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN562 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 610 563 startloop = jpiglo/2+1 - nimpp + 1 611 564 ELSE 612 565 startloop = endloop + 1 613 566 ENDIF 614 IF (startloop .le. endloop) THEN615 DO jk = 1, jpk567 IF( startloop <= endloop ) THEN 568 DO jk = 1, ipk 616 569 DO ji = startloop, endloop 617 570 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 … … 620 573 END DO 621 574 ENDIF 622 623 624 625 626 627 575 ! 576 END SELECT 577 ! 578 CASE DEFAULT ! * closed : the code probably never go through 579 ! 580 SELECT CASE ( cd_type) 628 581 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 629 pt3dl(:, 1 ,jk) = 0. e0630 pt3dl(:,ijpj,jk) = 0. e0582 pt3dl(:, 1 ,jk) = 0._wp 583 pt3dl(:,ijpj,jk) = 0._wp 631 584 CASE ( 'F' ) ! F-point 632 pt3dl(:,ijpj,jk) = 0.e0 633 END SELECT 634 ! 635 END SELECT ! npolj 636 ! 585 pt3dl(:,ijpj,jk) = 0._wp 586 END SELECT 587 ! 588 END SELECT ! npolj 637 589 ! 638 590 END SUBROUTINE mpp_lbc_nfd_3d … … 644 596 !! 645 597 !! ** Purpose : 2D lateral boundary condition : North fold treatment 646 !! without processor exchanges.598 !! without processor exchanges. 647 599 !! 648 600 !! ** Method : 649 601 !! 650 !! ** Action : pt2d with updated values along the north fold 651 !!---------------------------------------------------------------------- 652 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 653 ! ! = T , U , V , F , W points 654 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 655 ! ! = -1. , the sign is changed if north fold boundary 656 ! ! = 1. , the sign is kept if north fold boundary 602 !! ** Action : pt2dl with updated values along the north fold 603 !!---------------------------------------------------------------------- 657 604 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2dl ! 2D array on which the boundary condition is applied 658 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 659 608 ! 660 609 INTEGER :: ji … … 668 617 ! 669 618 ijpjm1 = ijpj-1 670 671 619 ! 620 ! 672 621 SELECT CASE ( npolj ) 673 622 ! … … 677 626 ! 678 627 CASE ( 'T' , 'W' ) ! T- , W-points 679 IF (nimpp .ne. 1) THEN628 IF( nimpp /= 1 ) THEN 680 629 startloop = 1 681 630 ELSE … … 686 635 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 687 636 END DO 688 IF (nimpp .eq. 1) THEN689 pt2dl(1,ijpj) 690 ENDIF 691 692 IF( nimpp .ge. (jpiglo/2+1)) THEN637 IF( nimpp == 1 ) THEN 638 pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2) 639 ENDIF 640 ! 641 IF( nimpp >= jpiglo/2+1 ) THEN 693 642 startloop = 1 694 ELSEIF( ((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN643 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 695 644 startloop = jpiglo/2+1 - nimpp + 1 696 645 ELSE … … 698 647 ENDIF 699 648 DO ji = startloop, nlci 700 ijt =jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4649 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 701 650 jia = ji + nimpp - 1 702 651 ijta = jpiglo - jia + 2 703 IF( (ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN652 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 704 653 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 705 654 ELSE … … 707 656 ENDIF 708 657 END DO 709 658 ! 710 659 CASE ( 'U' ) ! U-point 711 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN660 IF( nimpp + nlci - 1 /= jpiglo ) THEN 712 661 endloop = nlci 713 662 ELSE … … 718 667 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 719 668 END DO 720 669 ! 721 670 IF (nimpp .eq. 1) THEN 722 671 pt2dl( 1 ,ijpj ) = psgn * pt2dl( 2 ,ijpj-2) … … 726 675 pt2dl(nlci,ijpj ) = psgn * pt2dl(nlci-1,ijpj-2) 727 676 ENDIF 728 729 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN677 ! 678 IF( nimpp + nlci - 1 /= jpiglo ) THEN 730 679 endloop = nlci 731 680 ELSE 732 681 endloop = nlci - 1 733 682 ENDIF 734 IF( nimpp .ge. (jpiglo/2)) THEN683 IF( nimpp >= jpiglo/2 ) THEN 735 684 startloop = 1 736 ELSEIF( ((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN685 ELSEIF( nimpp+nlci-1 >= jpiglo/2 .AND. nimpp < jpiglo/2 ) THEN 737 686 startloop = jpiglo/2 - nimpp + 1 738 687 ELSE … … 743 692 jia = ji + nimpp - 1 744 693 ijua = jpiglo - jia + 1 745 IF( (ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN694 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 746 695 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 747 696 ELSE … … 749 698 ENDIF 750 699 END DO 751 700 ! 752 701 CASE ( 'V' ) ! V-point 753 IF (nimpp .ne. 1) THEN702 IF( nimpp /= 1 ) THEN 754 703 startloop = 1 755 704 ELSE … … 764 713 pt2dl( 1 ,ijpj) = psgn * pt2dl( 3 ,ijpj-3) 765 714 ENDIF 766 715 ! 767 716 CASE ( 'F' ) ! F-point 768 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN717 IF( nimpp + nlci - 1 /= jpiglo ) THEN 769 718 endloop = nlci 770 719 ELSE … … 784 733 pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2) 785 734 ENDIF 786 735 ! 787 736 CASE ( 'I' ) ! ice U-V point (I-point) 788 IF (nimpp .ne. 1) THEN737 IF( nimpp /= 1 ) THEN 789 738 startloop = 1 790 739 ELSE … … 796 745 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 797 746 END DO 798 799 CASE ( 'J' ) ! first ice U-V point 800 IF (nimpp .ne. 1) THEN 801 startloop = 1 802 ELSE 803 startloop = 3 804 pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 805 ENDIF 806 DO ji = startloop, nlci 807 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 808 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 809 END DO 810 811 CASE ( 'K' ) ! second ice U-V point 812 IF (nimpp .ne. 1) THEN 813 startloop = 1 814 ELSE 815 startloop = 3 816 pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 817 ENDIF 818 DO ji = startloop, nlci 819 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 820 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 821 END DO 822 747 ! 823 748 END SELECT 824 749 ! … … 831 756 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 832 757 END DO 833 758 ! 834 759 CASE ( 'U' ) ! U-point 835 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN760 IF( nimpp + nlci - 1 /= jpiglo ) THEN 836 761 endloop = nlci 837 762 ELSE … … 845 770 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 846 771 ENDIF 847 772 ! 848 773 CASE ( 'V' ) ! V-point 849 774 DO ji = 1, nlci … … 851 776 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 852 777 END DO 853 IF( nimpp .ge. (jpiglo/2+1)) THEN778 IF( nimpp >= jpiglo/2+1 ) THEN 854 779 startloop = 1 855 ELSEIF( ((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN780 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 856 781 startloop = jpiglo/2+1 - nimpp + 1 857 782 ELSE … … 862 787 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 863 788 END DO 864 789 ! 865 790 CASE ( 'F' ) ! F-point 866 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN791 IF( nimpp + nlci - 1 /= jpiglo ) THEN 867 792 endloop = nlci 868 793 ELSE … … 876 801 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 877 802 ENDIF 878 879 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN803 ! 804 IF( nimpp + nlci - 1 /= jpiglo ) THEN 880 805 endloop = nlci 881 806 ELSE 882 807 endloop = nlci - 1 883 808 ENDIF 884 IF( nimpp .ge. (jpiglo/2+1)) THEN809 IF( nimpp >= jpiglo/2+1 ) THEN 885 810 startloop = 1 886 ELSEIF( ((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN811 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 887 812 startloop = jpiglo/2+1 - nimpp + 1 888 813 ELSE 889 814 startloop = endloop + 1 890 815 ENDIF 891 816 ! 892 817 DO ji = startloop, endloop 893 818 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 894 819 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 895 820 END DO 896 821 ! 897 822 CASE ( 'I' ) ! ice U-V point (I-point) 898 IF (nimpp .ne. 1) THEN823 IF( nimpp /= 1 ) THEN 899 824 startloop = 1 900 825 ELSE 901 826 startloop = 2 902 827 ENDIF 903 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN828 IF( nimpp + nlci - 1 /= jpiglo ) THEN 904 829 endloop = nlci 905 830 ELSE … … 908 833 DO ji = startloop , endloop 909 834 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 910 pt2dl(ji,ijpj)= 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 911 END DO 912 913 CASE ( 'J' ) ! first ice U-V point 914 IF (nimpp .ne. 1) THEN 915 startloop = 1 916 ELSE 917 startloop = 2 918 ENDIF 919 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 920 endloop = nlci 921 ELSE 922 endloop = nlci - 1 923 ENDIF 924 DO ji = startloop , endloop 925 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 926 pt2dl(ji,ijpj) = pt2dl(ji,ijpjm1) 927 END DO 928 929 CASE ( 'K' ) ! second ice U-V point 930 IF (nimpp .ne. 1) THEN 931 startloop = 1 932 ELSE 933 startloop = 2 934 ENDIF 935 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 936 endloop = nlci 937 ELSE 938 endloop = nlci - 1 939 ENDIF 940 DO ji = startloop, endloop 941 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 942 pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) 943 END DO 944 835 pt2dl(ji,ijpj) = 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 836 END DO 837 ! 945 838 END SELECT 946 839 ! … … 949 842 SELECT CASE ( cd_type) 950 843 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 951 pt2dl(:, 1 ) = 0.e0952 pt2dl(:,ijpj) = 0. e0844 pt2dl(:, 1 ) = 0._wp 845 pt2dl(:,ijpj) = 0._wp 953 846 CASE ( 'F' ) ! F-point 954 pt2dl(:,ijpj) = 0. e0847 pt2dl(:,ijpj) = 0._wp 955 848 CASE ( 'I' ) ! ice U-V point 956 pt2dl(:, 1 ) = 0.e0 957 pt2dl(:,ijpj) = 0.e0 958 CASE ( 'J' ) ! first ice U-V point 959 pt2dl(:, 1 ) = 0.e0 960 pt2dl(:,ijpj) = 0.e0 961 CASE ( 'K' ) ! second ice U-V point 962 pt2dl(:, 1 ) = 0.e0 963 pt2dl(:,ijpj) = 0.e0 849 pt2dl(:, 1 ) = 0._wp 850 pt2dl(:,ijpj) = 0._wp 964 851 END SELECT 965 852 ! -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r7753 r7904 8 8 !! 8.0 ! 1998 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI 9 9 !! ! 1998 (J.M. Molines) Open boundary conditions 10 !! NEMO 1.0 ! 2003 (J. -M. Molines, G. Madec) F90, free form10 !! NEMO 1.0 ! 2003 (J.M. Molines, G. Madec) F90, free form 11 11 !! ! 2003 (J.M. Molines) add mpp_ini_north(_3d,_2d) 12 12 !! - ! 2004 (R. Bourdalle Badie) isend option in mpi … … 24 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple' 26 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max 27 !! 4.0 ! 2017 (G. Madec) automatique allocation of array argument (use any 3rd dimension) 27 28 !!---------------------------------------------------------------------- 28 29 … … 45 46 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 46 47 !! mpprecv : 47 !! mppsend : SUBROUTINE mpp_ini_znl48 !! mppsend : 48 49 !! mppscatter : 49 50 !! mppgather : … … 85 86 86 87 TYPE arrayptr 87 REAL , DIMENSION (:,:), POINTER ::pt2d88 REAL(wp), DIMENSION (:,:), POINTER :: pt2d 88 89 END TYPE arrayptr 90 ! 89 91 PUBLIC arrayptr 90 92 … … 101 103 INTERFACE mpp_sum 102 104 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 103 105 & mppsum_realdd, mppsum_a_realdd 104 106 END INTERFACE 105 107 INTERFACE mpp_lbc_north … … 112 114 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 113 115 END INTERFACE 114 115 116 INTERFACE mpp_max_multiple 116 117 MODULE PROCEDURE mppmax_real_multiple … … 138 139 ! variables used in case of sea-ice 139 140 INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in limthd) 140 INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology)141 INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology)142 INTEGER :: ndim_rank_ice ! number of 'ice' processors143 INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm141 INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology) 142 INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology) 143 INTEGER :: ndim_rank_ice ! number of 'ice' processors 144 INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm 144 145 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_ice ! dimension ndim_rank_ice 145 146 146 147 ! variables used for zonal integration 147 148 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average 148 LOGICAL, PUBLIC :: l_znl_root ! True on the 'left'most processor on the same row149 INTEGER :: ngrp_znl !group ID for the znl processors150 INTEGER :: ndim_rank_znl !number of processors on the same zonal average149 LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row 150 INTEGER :: ngrp_znl ! group ID for the znl processors 151 INTEGER :: ndim_rank_znl ! number of processors on the same zonal average 151 152 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 152 153 153 154 ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) 154 INTEGER, PUBLIC :: ngrp_world ! group ID for the world processors155 INTEGER, PUBLIC :: ngrp_opa ! group ID for the opa processors156 INTEGER, PUBLIC :: ngrp_north ! group ID for the northern processors (to be fold)157 INTEGER, PUBLIC :: ncomm_north ! communicator made by the processors belonging to ngrp_north158 INTEGER, PUBLIC :: ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !)159 INTEGER, PUBLIC :: njmppmax ! value of njmpp for the processors of the northern line160 INTEGER, PUBLIC :: north_root ! number (in the comm_opa) of proc 0 in the northern comm161 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: nrank_north !dimension ndim_rank_north155 INTEGER, PUBLIC :: ngrp_world !: group ID for the world processors 156 INTEGER, PUBLIC :: ngrp_opa !: group ID for the opa processors 157 INTEGER, PUBLIC :: ngrp_north !: group ID for the northern processors (to be fold) 158 INTEGER, PUBLIC :: ncomm_north !: communicator made by the processors belonging to ngrp_north 159 INTEGER, PUBLIC :: ndim_rank_north !: number of 'sea' processor in the northern line (can be /= jpni !) 160 INTEGER, PUBLIC :: njmppmax !: value of njmpp for the processors of the northern line 161 INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm 162 INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north 162 163 163 164 ! Type of send : standard, buffered, immediate 164 CHARACTER(len=1), PUBLIC :: cn_mpi_send !type od mpi send/recieve (S=standard, B=bsend, I=isend)165 LOGICAL , PUBLIC :: l_isend = .FALSE. !isend use indicator (T if cn_mpi_send='I')166 INTEGER , PUBLIC :: nn_buffer !size of the buffer in case of mpi_bsend167 168 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon! buffer in case of bsend169 170 LOGICAL, PUBLIC :: ln_nnogather !namelist control of northfold comms171 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !internal control of northfold comms172 INTEGER, PUBLIC :: ityp 165 CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 166 LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I') 167 INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend 168 169 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend 170 171 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 172 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 173 173 174 !!---------------------------------------------------------------------- 174 !! NEMO/OPA 3.3 , NEMO Consortium (2010)175 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 175 176 !! $Id$ 176 177 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 178 179 CONTAINS 179 180 180 181 FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 181 FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 182 182 !!---------------------------------------------------------------------- 183 183 !! *** routine mynode *** … … 204 204 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 205 205 ! 206 207 206 REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables 208 207 READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 209 208 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 210 209 ! 211 210 REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables 212 211 READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 213 212 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 214 213 ! 215 214 ! ! control print 216 215 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 217 216 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 218 217 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 219 218 ! 220 219 #if defined key_agrif 221 220 IF( .NOT. Agrif_Root() ) THEN … … 225 224 ENDIF 226 225 #endif 227 228 IF(jpnij < 1)THEN 229 ! If jpnij is not specified in namelist then we calculate it - this 230 ! means there will be no land cutting out. 231 jpnij = jpni * jpnj 232 END IF 233 234 IF( (jpni < 1) .OR. (jpnj < 1) )THEN 226 ! 227 IF( jpnij < 1 ) THEN ! If jpnij is not specified in namelist then we calculate it 228 jpnij = jpni * jpnj ! this means there will be no land cutting out. 229 ENDIF 230 231 IF( jpni < 1 .OR. jpnj < 1 ) THEN 235 232 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1 236 233 ELSE … … 238 235 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 239 236 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1 240 END 237 ENDIF 241 238 242 239 WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 … … 268 265 kstop = kstop + 1 269 266 END SELECT 270 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 267 ! 268 ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 271 269 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 272 270 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 … … 309 307 310 308 #if defined key_agrif 311 IF (Agrif_Root()) THEN309 IF( Agrif_Root() ) THEN 312 310 CALL Agrif_MPI_Init(mpi_comm_opa) 313 311 ELSE … … 335 333 !! 336 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 337 544 !! 338 545 !! ** Method : Use mppsend and mpprecv function for passing mask … … 347 554 !! noso : number for local neighboring processors 348 555 !! nono : number for local neighboring processors 349 !! 350 !! ** Action : ptab with update value at its periphery 351 !! 352 !!---------------------------------------------------------------------- 353 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 354 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 355 ! ! = T , U , V , F , W points 356 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 357 ! ! = 1. , the sign is kept 358 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 359 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 360 ! 361 INTEGER :: ji, jj, jk, jl ! dummy loop indices 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 362 565 INTEGER :: imigr, iihom, ijhom ! temporary integers 363 566 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 364 567 REAL(wp) :: zland 365 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 366 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 367 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 368 !!---------------------------------------------------------------------- 369 370 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 371 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 372 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) ) 373 575 ! 374 576 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value … … 378 580 ! 1. standard boundary treatment 379 581 ! ------------------------------ 380 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 381 ! 382 ! WARNING ptab is defined only between nld and nle 383 DO jk = 1, jpk 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 384 588 DO jj = nlcj+1, jpj ! added line(s) (inner only) 385 pt ab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk)386 pt ab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk)387 pt ab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk)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) 388 592 END DO 389 593 DO ji = nlci+1, jpi ! added column(s) (full) 390 pt ab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk)391 pt ab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk)392 pt ab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk)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) 393 597 END DO 394 END DO 395 ! 396 ELSE ! standard close or cyclic treatment 397 ! 398 ! ! East-West boundaries 399 ! !* Cyclic east-west 400 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 401 ptab( 1 ,:,:) = ptab(jpim1,:,:) 402 ptab(jpi,:,:) = ptab( 2 ,:,:) 403 ELSE !* closed 404 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 405 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 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 406 619 ENDIF 407 ! North-south cyclic 408 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south only with no mpp split in latitude 409 ptab(:,1 , :) = ptab(:, jpjm1,:) 410 ptab(:,jpj,:) = ptab(:, 2,:) 411 ELSE ! ! North-South boundaries (closed) 412 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 413 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 414 ENDIF 415 ! 416 ENDIF 620 END DO 417 621 418 622 ! 2. East and west directions exchange … … 420 624 ! we play with the neigbours AND the row number because of the periodicity 421 625 ! 422 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 423 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 424 iihom = nlci-nreci 425 DO jl = 1, jpreci 426 zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 427 zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 428 END DO 429 END SELECT 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 430 636 ! 431 637 ! ! Migrations 432 imigr = jpreci * jpj * jpk638 imigr = jpreci * jpj 433 639 ! 434 640 SELECT CASE ( nbondi ) 435 641 CASE ( -1 ) 436 CALL mppsend( 2, zt 3we(1,1,1,1),imigr, noea, ml_req1 )437 CALL mpprecv( 1, zt 3ew(1,1,1,2),imigr, noea )438 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat,ml_err)439 CASE ( 0 ) 440 CALL mppsend( 1, zt 3ew(1,1,1,1),imigr, nowe, ml_req1 )441 CALL mppsend( 2, zt 3we(1,1,1,1),imigr, noea, ml_req2 )442 CALL mpprecv( 1, zt 3ew(1,1,1,2),imigr, noea )443 CALL mpprecv( 2, zt 3we(1,1,1,2),imigr, nowe )444 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat,ml_err)445 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat,ml_err)446 CASE ( 1 ) 447 CALL mppsend( 1, zt 3ew(1,1,1,1),imigr, nowe, ml_req1 )448 CALL mpprecv( 2, zt 3we(1,1,1,2),imigr, nowe )449 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat,ml_err)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) 450 656 END SELECT 451 657 ! 452 658 ! ! Write Dirichlet lateral conditions 453 iihom = nlci-jpreci 454 ! 455 SELECT CASE ( nbondi ) 456 CASE ( -1 ) 457 DO jl = 1, jpreci 458 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 459 END DO 460 CASE ( 0 ) 461 DO jl = 1, jpreci 462 ptab(jl ,:,:) = zt3we(:,jl,:,2) 463 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 464 END DO 465 CASE ( 1 ) 466 DO jl = 1, jpreci 467 ptab(jl ,:,:) = zt3we(:,jl,:,2) 468 END DO 469 END SELECT 470 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 471 680 ! 3. North and south directions 472 681 ! ----------------------------- 473 682 ! always closed : we play only with the neigbours 474 683 ! 475 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 476 ijhom = nlcj-nrecj 477 DO jl = 1, jprecj 478 zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 479 zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 480 END DO 481 ENDIF 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 482 694 ! 483 695 ! ! Migrations 484 imigr = jprecj * jpi * jpk696 imigr = jprecj * jpi 485 697 ! 486 698 SELECT CASE ( nbondj ) 487 699 CASE ( -1 ) 488 CALL mppsend( 4, zt 3sn(1,1,1,1),imigr, nono, ml_req1 )489 CALL mpprecv( 3, zt 3ns(1,1,1,2),imigr, nono )490 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)491 CASE ( 0 ) 492 CALL mppsend( 3, zt 3ns(1,1,1,1),imigr, noso, ml_req1 )493 CALL mppsend( 4, zt 3sn(1,1,1,1),imigr, nono, ml_req2 )494 CALL mpprecv( 3, zt 3ns(1,1,1,2),imigr, nono )495 CALL mpprecv( 4, zt 3sn(1,1,1,2),imigr, noso )496 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat,ml_err)497 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat,ml_err)498 CASE ( 1 ) 499 CALL mppsend( 3, zt 3ns(1,1,1,1),imigr, noso, ml_req1 )500 CALL mpprecv( 4, zt 3sn(1,1,1,2),imigr, noso )501 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat,ml_err)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) 502 714 END SELECT 503 715 ! 504 716 ! ! Write Dirichlet lateral conditions 505 ijhom = nlcj-jprecj 506 ! 507 SELECT CASE ( nbondj ) 508 CASE ( -1 ) 509 DO jl = 1, jprecj 510 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 511 END DO 512 CASE ( 0 ) 513 DO jl = 1, jprecj 514 ptab(:,jl ,:) = zt3sn(:,jl,:,2) 515 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 516 END DO 517 CASE ( 1 ) 518 DO jl = 1, jprecj 519 ptab(:,jl,:) = zt3sn(:,jl,:,2) 520 END DO 521 END SELECT 522 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 523 737 ! 4. north fold treatment 524 738 ! ----------------------- 525 739 ! 526 IF( npolj /= 0 .AND. .NOT. 740 IF( npolj /= 0 .AND. .NOT.PRESENT(cd_mpp) ) THEN 527 741 ! 528 742 SELECT CASE ( jpni ) 529 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 530 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 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. 531 749 END SELECT 532 750 ! 533 751 ENDIF 534 752 ! 535 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 536 ! 537 END SUBROUTINE mpp_lnk_3d 538 539 540 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 541 !!---------------------------------------------------------------------- 542 !! *** routine mpp_lnk_2d_multiple *** 543 !! 544 !! ** Purpose : Message passing management for multiple 2d arrays 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 775 776 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 545 824 !! 546 825 !! ** Method : Use mppsend and mpprecv function for passing mask … … 555 834 !! noso : number for local neighboring processors 556 835 !! nono : number for local neighboring processors 557 !! ----------------------------------------------------------------------558 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points559 ! ! = T , U , V , F , W and I points560 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary561 ! ! = 1. , the sign is kept562 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp! fill the overlap area only563 REAL(wp) , OPTIONAL , INTENT(in ) :: pval! background value (used at closed boundaries)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) 564 843 !! 565 844 INTEGER :: ji, jj, jl ! dummy loop indices 566 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES567 845 INTEGER :: imigr, iihom, ijhom ! temporary integers 568 846 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 569 INTEGER :: num_fields570 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array571 847 REAL(wp) :: zland 572 INTEGER , DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for key_mpi_isend848 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 573 849 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 574 850 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 575 576 !!---------------------------------------------------------------------- 577 ! 578 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 579 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 851 !!---------------------------------------------------------------------- 852 ! 853 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 854 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 580 855 ! 581 856 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value … … 586 861 ! ------------------------------ 587 862 ! 588 !First Array 589 DO ii = 1 , num_fields 590 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 591 ! 592 ! WARNING pt2d is defined only between nld and nle 593 DO jj = nlcj+1, jpj ! added line(s) (inner only) 594 pt2d_array(ii)%pt2d(nldi :nlei , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 595 pt2d_array(ii)%pt2d(1 :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi , nlej) 596 pt2d_array(ii)%pt2d(nlei+1:nlci , jj) = pt2d_array(ii)%pt2d( nlei, nlej) 597 END DO 598 DO ji = nlci+1, jpi ! added column(s) (full) 599 pt2d_array(ii)%pt2d(ji, nldj :nlej ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 600 pt2d_array(ii)%pt2d(ji, 1 :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj ) 601 pt2d_array(ii)%pt2d(ji, nlej+1:jpj ) = pt2d_array(ii)%pt2d(nlei, nlej) 602 END DO 603 ! 604 ELSE ! standard close or cyclic treatment 605 ! 606 ! ! East-West boundaries 607 IF( nbondi == 2 .AND. & ! Cyclic east-west 608 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 609 pt2d_array(ii)%pt2d( 1 , : ) = pt2d_array(ii)%pt2d( jpim1, : ) ! west 610 pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d( 2 , : ) ! east 611 ELSE ! closed 612 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( 1 : jpreci,:) = zland ! south except F-point 613 pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north 614 ENDIF 615 ! Noth-South boundaries 616 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south 617 pt2d_array(ii)%pt2d(:, 1 ) = pt2d_array(ii)%pt2d(:, jpjm1 ) 618 pt2d_array(ii)%pt2d(:, jpj ) = pt2d_array(ii)%pt2d(:, 2 ) 619 ELSE ! 620 ! ! North-South boundaries (closed) 621 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d(:, 1:jprecj ) = zland ! south except F-point 622 pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north 623 ! 624 ENDIF 625 ENDIF 626 END DO 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 627 898 628 899 ! 2. East and west directions exchange … … 630 901 ! we play with the neigbours AND the row number because of the periodicity 631 902 ! 632 DO ii = 1 , num_fields 633 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 634 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 635 iihom = nlci-nreci 636 DO jl = 1, jpreci 637 zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 638 zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 639 END DO 640 END SELECT 641 END DO 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 642 911 ! 643 912 ! ! Migrations … … 646 915 SELECT CASE ( nbondi ) 647 916 CASE ( -1 ) 648 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 )649 CALL mpprecv( 1, zt2ew(1,1, num_fields+1), num_fields*imigr, noea )917 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 918 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 650 919 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 651 920 CASE ( 0 ) 652 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 )653 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 )654 CALL mpprecv( 1, zt2ew(1,1, num_fields+1), num_fields*imigr, noea )655 CALL mpprecv( 2, zt2we(1,1, num_fields+1), num_fields*imigr, nowe )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 ) 656 925 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 657 926 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 658 927 CASE ( 1 ) 659 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 )660 CALL mpprecv( 2, zt2we(1,1, num_fields+1), num_fields*imigr, nowe )928 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 929 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 661 930 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 662 931 END SELECT … … 665 934 iihom = nlci - jpreci 666 935 ! 667 668 DO ii = 1 , num_fields 669 SELECT CASE ( nbondi ) 670 CASE ( -1 ) 671 DO jl = 1, jpreci 672 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 673 END DO 674 CASE ( 0 ) 675 DO jl = 1, jpreci 676 pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 677 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 678 END DO 679 CASE ( 1 ) 680 DO jl = 1, jpreci 681 pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 682 END DO 683 END SELECT 684 END DO 685 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 686 952 ! 3. North and south directions 687 953 ! ----------------------------- 688 954 ! always closed : we play only with the neigbours 689 955 ! 690 !First Array 691 DO ii = 1 , num_fields 692 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 693 ijhom = nlcj-nrecj 694 DO jl = 1, jprecj 695 zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 696 zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 697 END DO 698 ENDIF 699 END DO 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 700 963 ! 701 964 ! ! Migrations … … 704 967 SELECT CASE ( nbondj ) 705 968 CASE ( -1 ) 706 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 )707 CALL mpprecv( 3, zt2ns(1,1, num_fields+1), num_fields*imigr, nono )969 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 970 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 708 971 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 709 972 CASE ( 0 ) 710 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 )711 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 )712 CALL mpprecv( 3, zt2ns(1,1, num_fields+1), num_fields*imigr, nono )713 CALL mpprecv( 4, zt2sn(1,1, num_fields+1), num_fields*imigr, noso )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 ) 714 977 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 715 978 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 716 979 CASE ( 1 ) 717 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 )718 CALL mpprecv( 4, zt2sn(1,1, num_fields+1), num_fields*imigr, noso )980 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 981 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 719 982 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 720 983 END SELECT … … 723 986 ijhom = nlcj - jprecj 724 987 ! 725 726 DO ii = 1 , num_fields 727 !First Array 728 SELECT CASE ( nbondj ) 729 CASE ( -1 ) 730 DO jl = 1, jprecj 731 pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 732 END DO 733 CASE ( 0 ) 734 DO jl = 1, jprecj 735 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 736 pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 737 END DO 738 CASE ( 1 ) 739 DO jl = 1, jprecj 740 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 741 END DO 742 END SELECT 743 END DO 744 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 745 1004 ! 4. north fold treatment 746 1005 ! ----------------------- 747 1006 ! 748 !First Array749 1007 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 750 1008 ! 751 1009 SELECT CASE ( jpni ) 752 CASE ( 1 ) ; 753 DO ii = 1 , num_fields 754 CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 755 END DO 756 CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. 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. 757 1012 END SELECT 758 1013 ! 759 1014 ENDIF 760 !761 1015 ! 762 1016 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 763 1017 ! 764 END SUBROUTINE mpp_lnk_2d_multiple 765 766 767 SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) 768 !!--------------------------------------------------------------------- 769 REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 770 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 771 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 772 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 773 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 774 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 775 INTEGER , INTENT (inout) :: num_fields 776 !!--------------------------------------------------------------------- 777 num_fields = num_fields + 1 778 pt2d_array(num_fields)%pt2d => pt2d 779 type_array(num_fields) = cd_type 780 psgn_array(num_fields) = psgn 781 END SUBROUTINE load_array 782 783 784 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 785 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 786 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 787 !!--------------------------------------------------------------------- 788 ! Second 2D array on which the boundary condition is applied 789 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 790 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 791 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 792 ! define the nature of ptab array grid-points 793 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 794 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 795 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 796 ! =-1 the sign change across the north fold boundary 797 REAL(wp) , INTENT(in ) :: psgnA 798 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 799 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 800 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 801 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 802 !! 803 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 804 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 805 ! ! = T , U , V , F , W and I points 806 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 807 INTEGER :: num_fields 808 !!--------------------------------------------------------------------- 809 ! 810 num_fields = 0 811 ! 812 ! Load the first array 813 CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 814 ! 815 ! Look if more arrays are added 816 IF( PRESENT(psgnB) ) CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 817 IF( PRESENT(psgnC) ) CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 818 IF( PRESENT(psgnD) ) CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 819 IF( PRESENT(psgnE) ) CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 820 IF( PRESENT(psgnF) ) CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 821 IF( PRESENT(psgnG) ) CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 822 IF( PRESENT(psgnH) ) CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 823 IF( PRESENT(psgnI) ) CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 824 ! 825 CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 826 ! 827 END SUBROUTINE mpp_lnk_2d_9 828 829 830 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 831 !!---------------------------------------------------------------------- 832 !! *** routine mpp_lnk_2d *** 833 !! 834 !! ** Purpose : Message passing manadgement for 2d array 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 835 1026 !! 836 1027 !! ** Method : Use mppsend and mpprecv function for passing mask … … 846 1037 !! nono : number for local neighboring processors 847 1038 !! 848 !!----------------------------------------------------------------------849 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied850 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points851 ! ! = T , U , V , F , W and I points852 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary853 ! ! = 1. , the sign is kept854 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only855 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)856 !!857 INTEGER :: ji, jj, jl ! dummy loop indices858 INTEGER :: imigr, iihom, ijhom ! temporary integers859 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend860 REAL(wp) :: zland861 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend862 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north863 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east864 !!----------------------------------------------------------------------865 !866 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &867 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )868 !869 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value870 ELSE ; zland = 0._wp ! zero by default871 ENDIF872 873 ! 1. standard boundary treatment874 ! ------------------------------875 !876 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values877 !878 ! WARNING pt2d is defined only between nld and nle879 DO jj = nlcj+1, jpj ! added line(s) (inner only)880 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej)881 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej)882 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej)883 END DO884 DO ji = nlci+1, jpi ! added column(s) (full)885 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej)886 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj )887 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej)888 END DO889 !890 ELSE ! standard close or cyclic treatment891 !892 ! ! East-West boundaries893 IF( nbondi == 2 .AND. & ! Cyclic east-west894 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN895 pt2d( 1 ,:) = pt2d(jpim1,:) ! west896 pt2d(jpi,:) = pt2d( 2 ,:) ! east897 ELSE ! closed898 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point899 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north900 ENDIF901 ! North-South boudaries902 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south903 pt2d(:, 1 ) = pt2d(:,jpjm1)904 pt2d(:, jpj) = pt2d(:, 2)905 ELSE906 ! ! North-South boundaries (closed)907 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point908 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north909 ENDIF910 ENDIF911 912 ! 2. East and west directions exchange913 ! ------------------------------------914 ! we play with the neigbours AND the row number because of the periodicity915 !916 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions917 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)918 iihom = nlci-nreci919 DO jl = 1, jpreci920 zt2ew(:,jl,1) = pt2d(jpreci+jl,:)921 zt2we(:,jl,1) = pt2d(iihom +jl,:)922 END DO923 END SELECT924 !925 ! ! Migrations926 imigr = jpreci * jpj927 !928 SELECT CASE ( nbondi )929 CASE ( -1 )930 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )931 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )932 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)933 CASE ( 0 )934 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )935 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )936 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )937 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )938 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)939 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)940 CASE ( 1 )941 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )942 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )943 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)944 END SELECT945 !946 ! ! Write Dirichlet lateral conditions947 iihom = nlci - jpreci948 !949 SELECT CASE ( nbondi )950 CASE ( -1 )951 DO jl = 1, jpreci952 pt2d(iihom+jl,:) = zt2ew(:,jl,2)953 END DO954 CASE ( 0 )955 DO jl = 1, jpreci956 pt2d(jl ,:) = zt2we(:,jl,2)957 pt2d(iihom+jl,:) = zt2ew(:,jl,2)958 END DO959 CASE ( 1 )960 DO jl = 1, jpreci961 pt2d(jl ,:) = zt2we(:,jl,2)962 END DO963 END SELECT964 965 966 ! 3. North and south directions967 ! -----------------------------968 ! always closed : we play only with the neigbours969 !970 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions971 ijhom = nlcj-nrecj972 DO jl = 1, jprecj973 zt2sn(:,jl,1) = pt2d(:,ijhom +jl)974 zt2ns(:,jl,1) = pt2d(:,jprecj+jl)975 END DO976 ENDIF977 !978 ! ! Migrations979 imigr = jprecj * jpi980 !981 SELECT CASE ( nbondj )982 CASE ( -1 )983 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )984 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )985 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)986 CASE ( 0 )987 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )988 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )989 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )990 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )991 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)992 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)993 CASE ( 1 )994 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )995 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )996 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)997 END SELECT998 !999 ! ! Write Dirichlet lateral conditions1000 ijhom = nlcj - jprecj1001 !1002 SELECT CASE ( nbondj )1003 CASE ( -1 )1004 DO jl = 1, jprecj1005 pt2d(:,ijhom+jl) = zt2ns(:,jl,2)1006 END DO1007 CASE ( 0 )1008 DO jl = 1, jprecj1009 pt2d(:,jl ) = zt2sn(:,jl,2)1010 pt2d(:,ijhom+jl) = zt2ns(:,jl,2)1011 END DO1012 CASE ( 1 )1013 DO jl = 1, jprecj1014 pt2d(:,jl ) = zt2sn(:,jl,2)1015 END DO1016 END SELECT1017 1018 1019 ! 4. north fold treatment1020 ! -----------------------1021 !1022 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN1023 !1024 SELECT CASE ( jpni )1025 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp1026 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.1027 END SELECT1028 !1029 ENDIF1030 !1031 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )1032 !1033 END SUBROUTINE mpp_lnk_2d1034 1035 1036 SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )1037 !!----------------------------------------------------------------------1038 !! *** routine mpp_lnk_3d_gather ***1039 !!1040 !! ** Purpose : Message passing manadgement for two 3D arrays1041 !!1042 !! ** Method : Use mppsend and mpprecv function for passing mask1043 !! between processors following neighboring subdomains.1044 !! domain parameters1045 !! nlci : first dimension of the local subdomain1046 !! nlcj : second dimension of the local subdomain1047 !! nbondi : mark for "east-west local boundary"1048 !! nbondj : mark for "north-south local boundary"1049 !! noea : number for local neighboring processors1050 !! nowe : number for local neighboring processors1051 !! noso : number for local neighboring processors1052 !! nono : number for local neighboring processors1053 !!1054 1039 !! ** Action : ptab1 and ptab2 with update value at its periphery 1055 1040 !! 1056 1041 !!---------------------------------------------------------------------- 1057 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which 1058 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab2 ! the boundary condition is applied 1059 CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays 1060 CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! i.e. grid-points = T , U , V , F or W points 1061 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1062 !! ! = 1. , the sign is kept 1063 INTEGER :: jl ! dummy loop indices 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 1064 1050 INTEGER :: imigr, iihom, ijhom ! temporary integers 1065 1051 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend … … 1069 1055 !!---------------------------------------------------------------------- 1070 1056 ! 1071 ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) , & 1072 & zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 1073 ! 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 1074 1062 ! 1. standard boundary treatment 1075 1063 ! ------------------------------ 1076 1064 ! ! East-West boundaries 1077 ! !* Cyclic east-west1065 ! !* Cyclic 1078 1066 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1079 1067 ptab1( 1 ,:,:) = ptab1(jpim1,:,:) … … 1082 1070 ptab2(jpi,:,:) = ptab2( 2 ,:,:) 1083 1071 ELSE !* closed 1084 IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0.e0 ! south except at F-point 1085 IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0.e0 1086 ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 ! north 1087 ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0 1088 ENDIF 1089 ! North-South boundaries 1090 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south 1091 ptab1(:, 1 ,:) = ptab1(: , jpjm1 , :) 1092 ptab1(:, jpj ,:) = ptab1(: , 2 , :) 1093 ptab2(:, 1 ,:) = ptab2(: , jpjm1 , :) 1094 ptab2(:, jpj ,:) = ptab2(: , 2 , :) 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 , :) 1095 1084 ELSE 1096 ! ! North-South boundariesclosed1097 IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0.e0! south except at F-point1098 IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0.e01099 ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0! north1100 ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e01101 ENDIF 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 1102 1091 1103 1092 ! 2. East and west directions exchange … … 1117 1106 ! 1118 1107 ! ! Migrations 1119 imigr = jpreci * jpj * jpk *21108 imigr = jpreci * jpj * ipk *2 1120 1109 ! 1121 1110 SELECT CASE ( nbondi ) … … 1159 1148 END DO 1160 1149 END SELECT 1161 1162 1150 1163 1151 ! 3. North and south directions … … 1176 1164 ! 1177 1165 ! ! Migrations 1178 imigr = jprecj * jpi * jpk * 21166 imigr = jprecj * jpi * ipk * 2 1179 1167 ! 1180 1168 SELECT CASE ( nbondj ) … … 1218 1206 END DO 1219 1207 END SELECT 1220 1221 1208 1222 1209 ! 4. north fold treatment … … 1284 1271 1285 1272 1286 ! 1. standard boundary treatment 1273 ! 1. standard boundary treatment (CAUTION: the order matters Here !!!! ) 1287 1274 ! ------------------------------ 1288 ! Order matters Here !!!! 1289 ! 1290 ! North-South cyclic 1291 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south 1292 pt2d(:, 1-jprj: 1 ) = pt2d ( :, jpjm1-jprj:jpjm1) 1275 ! !== North-South boundaries 1276 ! !* cyclic 1277 IF( nbondj == 2 .AND. jperio == 7 ) THEN 1278 pt2d(:, 1-jprj: 1 ) = pt2d ( :, jpjm1-jprj:jpjm1 ) 1293 1279 pt2d(:, jpj :jpj+jprj) = pt2d ( :, 2 :2+jprj) 1294 ELSE 1295 1296 ! !* North-South boundaries (closed) 1297 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0.e0 ! south except at F-point 1298 pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0 ! north 1299 ENDIF 1300 1301 ! ! East-West boundaries 1302 ! !* Cyclic east-west 1280 ELSE !* closed 1281 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0._wp ! south except at F-point 1282 pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0._wp ! north 1283 ENDIF 1284 ! !== East-West boundaries 1285 ! !* Cyclic east-west 1303 1286 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1304 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 1305 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 1306 ! 1307 ELSE !* closed 1308 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point 1309 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north 1310 ENDIF 1311 ! 1312 1287 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 1288 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 1289 ELSE !* closed 1290 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point 1291 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north 1292 ENDIF 1293 ! 1313 1294 ! north fold treatment 1314 ! -------------------- ---1295 ! -------------------- 1315 1296 IF( npolj /= 0 ) THEN 1316 1297 ! 1317 1298 SELECT CASE ( jpni ) 1318 1299 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 1319 CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn)1300 CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn ) 1320 1301 END SELECT 1321 1302 ! … … 1375 1356 END SELECT 1376 1357 1377 1378 1358 ! 3. North and south directions 1379 1359 ! ----------------------------- … … 1429 1409 ! 1430 1410 END SUBROUTINE mpp_lnk_2d_e 1411 1431 1412 1432 1413 SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) … … 1452 1433 !!---------------------------------------------------------------------- 1453 1434 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 1454 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1455 ! ! = T , U , V , F , W points 1456 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1457 ! ! = 1. , the sign is kept 1435 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 1436 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 1458 1437 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1459 1438 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 1460 ! !1439 ! 1461 1440 INTEGER :: ji, jj, jk, jl ! dummy loop indices 1462 1441 INTEGER :: imigr, iihom, ijhom ! temporary integers … … 1467 1446 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 1468 1447 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 1469 1470 !!---------------------------------------------------------------------- 1471 1448 !!---------------------------------------------------------------------- 1449 ! 1472 1450 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 1473 1451 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 1474 1475 1452 ! 1476 1453 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1477 ELSE ; zland = 0. e0! zero by default1454 ELSE ; zland = 0._wp ! zero by default 1478 1455 ENDIF 1479 1456 … … 1488 1465 iihom = nlci-jpreci 1489 1466 DO jl = 1, jpreci 1490 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0. 0_wp1491 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0. 0_wp1467 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0._wp 1468 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0._wp 1492 1469 END DO 1493 1470 END SELECT … … 1520 1497 CASE ( -1 ) 1521 1498 DO jl = 1, jpreci 1522 ptab(iihom +jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2)1499 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 1523 1500 END DO 1524 1501 CASE ( 0 ) … … 1533 1510 END SELECT 1534 1511 1535 1536 1512 ! 3. North and south directions 1537 1513 ! ----------------------------- … … 1541 1517 ijhom = nlcj-jprecj 1542 1518 DO jl = 1, jprecj 1543 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp1544 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0.0_wp1519 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0._wp 1520 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0._wp 1545 1521 END DO 1546 1522 ENDIF … … 1586 1562 END SELECT 1587 1563 1588 1589 1564 ! 4. north fold treatment 1590 1565 ! ----------------------- … … 1602 1577 ! 1603 1578 END SUBROUTINE mpp_lnk_sum_3d 1579 1604 1580 1605 1581 SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) … … 1620 1596 !! noso : number for local neighboring processors 1621 1597 !! nono : number for local neighboring processors 1622 !!1623 1598 !!---------------------------------------------------------------------- 1624 1599 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 1625 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1626 ! ! = T , U , V , F , W and I points 1627 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1628 ! ! = 1. , the sign is kept 1600 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points 1601 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 1629 1602 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1630 1603 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) … … 1638 1611 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 1639 1612 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 1640 1641 !!---------------------------------------------------------------------- 1642 1613 !!---------------------------------------------------------------------- 1614 ! 1643 1615 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 1644 1616 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 1645 1646 1617 ! 1647 1618 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1648 ELSE ; zland = 0. e0! zero by default1619 ELSE ; zland = 0._wp ! zero by default 1649 1620 ENDIF 1650 1621 … … 1757 1728 END SELECT 1758 1729 1759 1760 1730 ! 4. north fold treatment 1761 1731 ! ----------------------- … … 1773 1743 ! 1774 1744 END SUBROUTINE mpp_lnk_sum_2d 1745 1775 1746 1776 1747 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) … … 2015 1986 !! *** routine mppmax_a_real *** 2016 1987 !! 2017 !! ** Purpose : Maximum 2018 !! 2019 !!---------------------------------------------------------------------- 2020 INTEGER , INTENT(in ) :: kdim2021 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab2022 INTEGER , INTENT(in ), OPTIONAL:: kcom1988 !! ** 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 2023 1994 ! 2024 1995 INTEGER :: ierror, localcomm … … 2039 2010 !! *** routine mppmax_real *** 2040 2011 !! 2041 !! ** Purpose : Maximum 2012 !! ** Purpose : Maximum for each element of a 1D array 2042 2013 !! 2043 2014 !!---------------------------------------------------------------------- … … 2057 2028 END SUBROUTINE mppmax_real 2058 2029 2059 SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) 2030 2031 SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom ) 2060 2032 !!---------------------------------------------------------------------- 2061 2033 !! *** routine mppmax_real *** … … 2064 2036 !! 2065 2037 !!---------------------------------------------------------------------- 2066 REAL(wp), DIMENSION( :) , INTENT(inout) :: ptab ! ???2067 INTEGER , INTENT(in ) :: NUM2068 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ???2038 REAL(wp), DIMENSION(kdim), INTENT(inout) :: pt1d ! 1D arrays 2039 INTEGER , INTENT(in ) :: kdim 2040 INTEGER , OPTIONAL , INTENT(in ) :: kcom ! local communicator 2069 2041 !! 2070 2042 INTEGER :: ierror, localcomm 2071 REAL(wp) , POINTER , DIMENSION(:) :: zwork 2072 !!---------------------------------------------------------------------- 2073 ! 2074 CALL wrk_alloc(NUM , zwork) 2043 REAL(wp), DIMENSION(kdim) :: zwork 2044 !!---------------------------------------------------------------------- 2045 ! 2075 2046 localcomm = mpi_comm_opa 2076 2047 IF( PRESENT(kcom) ) localcomm = kcom 2077 2048 ! 2078 CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 2079 ptab = zwork 2080 CALL wrk_dealloc(NUM , zwork) 2049 CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 2050 pt1d(:) = zwork(:) 2081 2051 ! 2082 2052 END SUBROUTINE mppmax_real_multiple … … 2243 2213 REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask 2244 2214 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 2245 INTEGER , INTENT( out) :: ki, kj 2215 INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame 2246 2216 ! 2247 2217 INTEGER :: ierror … … 2251 2221 !!----------------------------------------------------------------------- 2252 2222 ! 2253 zmin = MINVAL( ptab(:,:) , mask= pmask == 1. e0)2254 ilocs = MINLOC( ptab(:,:) , mask= pmask == 1. e0)2223 zmin = MINVAL( ptab(:,:) , mask= pmask == 1._wp ) 2224 ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp ) 2255 2225 ! 2256 2226 ki = ilocs(1) + nimpp - 1 … … 2279 2249 !! 2280 2250 !!-------------------------------------------------------------------------- 2281 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array2282 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask2283 REAL(wp) 2284 INTEGER 2285 ! !2251 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! Local 2D array 2252 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! Local mask 2253 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 2254 INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame 2255 ! 2286 2256 INTEGER :: ierror 2287 2257 REAL(wp) :: zmin ! local minimum … … 2290 2260 !!----------------------------------------------------------------------- 2291 2261 ! 2292 zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1. e0)2293 ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1. e0)2262 zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 2263 ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 2294 2264 ! 2295 2265 ki = ilocs(1) + nimpp - 1 … … 2297 2267 kk = ilocs(3) 2298 2268 ! 2299 zain(1,:) =zmin2300 zain(2,:) =ki+10000.*kj+100000000.*kk2269 zain(1,:) = zmin 2270 zain(2,:) = ki + 10000.*kj + 100000000.*kk 2301 2271 ! 2302 2272 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) … … 2331 2301 !!----------------------------------------------------------------------- 2332 2302 ! 2333 zmax = MAXVAL( ptab(:,:) , mask= pmask == 1. e0)2334 ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1. e0)2303 zmax = MAXVAL( ptab(:,:) , mask= pmask == 1._wp ) 2304 ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp ) 2335 2305 ! 2336 2306 ki = ilocs(1) + nimpp - 1 … … 2359 2329 !! 2360 2330 !!-------------------------------------------------------------------------- 2361 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array 2362 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask 2363 REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab 2364 INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame 2365 !! 2366 REAL(wp) :: zmax ! local maximum 2331 REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: ptab ! Local 2D array 2332 REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: pmask ! Local mask 2333 REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab 2334 INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame 2335 ! 2336 INTEGER :: ierror ! local integer 2337 REAL(wp) :: zmax ! local maximum 2367 2338 REAL(wp), DIMENSION(2,1) :: zain, zaout 2368 2339 INTEGER , DIMENSION(3) :: ilocs 2369 INTEGER :: ierror2370 2340 !!----------------------------------------------------------------------- 2371 2341 ! 2372 zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1. e0)2373 ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1. e0)2342 zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 2343 ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 2374 2344 ! 2375 2345 ki = ilocs(1) + nimpp - 1 … … 2377 2347 kk = ilocs(3) 2378 2348 ! 2379 zain(1,:) =zmax2380 zain(2,:) =ki+10000.*kj+100000000.*kk2349 zain(1,:) = zmax 2350 zain(2,:) = ki + 10000.*kj + 100000000.*kk 2381 2351 ! 2382 2352 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) … … 2422 2392 2423 2393 SUBROUTINE mpp_comm_free( kcom ) 2424 !!----------------------------------------------------------------------2425 2394 !!---------------------------------------------------------------------- 2426 2395 INTEGER, INTENT(in) :: kcom … … 2692 2661 !! and apply lbc north-fold on this sub array. Then we 2693 2662 !! scatter the north fold array back to the processors. 2694 !! 2695 !!---------------------------------------------------------------------- 2696 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied 2697 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2698 ! ! = T , U , V , F or W gridpoints 2699 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2700 !! ! = 1. , the sign is kept 2663 !!---------------------------------------------------------------------- 2664 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied 2665 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2666 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 2667 ! 2701 2668 INTEGER :: ji, jj, jr, jk 2669 INTEGER :: ipk ! 3rd dimension of the input array 2702 2670 INTEGER :: ierr, itaille, ildi, ilei, iilb 2703 2671 INTEGER :: ijpj, ijpjm1, ij, iproc … … 2715 2683 !!---------------------------------------------------------------------- 2716 2684 ! 2717 ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) ) 2718 ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) ) 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) ) 2719 2689 2720 2690 ijpj = 4 2721 2691 ijpjm1 = 3 2722 2692 ! 2723 znorthloc(:,:,:) = 0 2724 DO jk = 1, jpk2693 znorthloc(:,:,:) = 0._wp 2694 DO jk = 1, ipk 2725 2695 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d 2726 2696 ij = jj - nlcj + ijpj … … 2730 2700 ! 2731 2701 ! ! Build in procs of ncomm_north the znorthgloio 2732 itaille = jpi * jpk * ijpj2702 itaille = jpi * ipk * ijpj 2733 2703 2734 2704 IF ( l_north_nogather ) THEN 2735 2705 ! 2736 ztabr(:,:,:) = 0 2737 ztabl(:,:,:) = 0 2738 2739 DO jk = 1, jpk2706 ztabr(:,:,:) = 0._wp 2707 ztabl(:,:,:) = 0._wp 2708 2709 DO jk = 1, ipk 2740 2710 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2741 2711 ij = jj - nlcj + ijpj … … 2747 2717 2748 2718 DO jr = 1,nsndto 2749 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN2719 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 2750 2720 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 2751 2721 ENDIF … … 2753 2723 DO jr = 1,nsndto 2754 2724 iproc = nfipproc(isendto(jr),jpnj) 2755 IF(iproc .ne.-1) THEN2725 IF(iproc /= -1) THEN 2756 2726 ilei = nleit (iproc+1) 2757 2727 ildi = nldit (iproc+1) 2758 2728 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2759 2729 ENDIF 2760 IF( (iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN2730 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 2761 2731 CALL mpprecv(5, zfoldwk, itaille, iproc) 2762 DO jk = 1, jpk2732 DO jk = 1, ipk 2763 2733 DO jj = 1, ijpj 2764 2734 DO ji = ildi, ilei … … 2767 2737 END DO 2768 2738 END DO 2769 ELSE IF (iproc .eq. (narea-1)) THEN2770 DO jk = 1, jpk2739 ELSE IF( iproc == narea-1 ) THEN 2740 DO jk = 1, ipk 2771 2741 DO jj = 1, ijpj 2772 2742 DO ji = ildi, ilei … … 2779 2749 IF (l_isend) THEN 2780 2750 DO jr = 1,nsndto 2781 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN2782 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err)2751 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 2752 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 2783 2753 ENDIF 2784 2754 END DO 2785 2755 ENDIF 2786 2756 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition 2787 DO jk = 1, jpk2757 DO jk = 1, ipk 2788 2758 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2789 2759 ij = jj - nlcj + ijpj … … 2794 2764 END DO 2795 2765 ! 2796 2797 2766 ELSE 2798 2767 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & 2799 2768 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2800 2769 ! 2801 ztab(:,:,:) = 0. e02770 ztab(:,:,:) = 0._wp 2802 2771 DO jr = 1, ndim_rank_north ! recover the global north array 2803 2772 iproc = nrank_north(jr) + 1 … … 2805 2774 ilei = nleit (iproc) 2806 2775 iilb = nimppt(iproc) 2807 DO jk = 1, jpk2776 DO jk = 1, ipk 2808 2777 DO jj = 1, ijpj 2809 2778 DO ji = ildi, ilei … … 2815 2784 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition 2816 2785 ! 2817 DO jk = 1, jpk2786 DO jk = 1, ipk 2818 2787 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2819 2788 ij = jj - nlcj + ijpj … … 2902 2871 2903 2872 DO jr = 1,nsndto 2904 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN2905 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr))2873 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 2874 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 2906 2875 ENDIF 2907 2876 END DO 2908 2877 DO jr = 1,nsndto 2909 2878 iproc = nfipproc(isendto(jr),jpnj) 2910 IF( iproc .ne. -1) THEN2879 IF( iproc /= -1 ) THEN 2911 2880 ilei = nleit (iproc+1) 2912 2881 ildi = nldit (iproc+1) 2913 2882 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2914 2883 ENDIF 2915 IF( (iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN2884 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 2916 2885 CALL mpprecv(5, zfoldwk, itaille, iproc) 2917 2886 DO jj = 1, ijpj … … 2920 2889 END DO 2921 2890 END DO 2922 ELSE IF (iproc .eq. (narea-1)) THEN2891 ELSEIF( iproc == narea-1 ) THEN 2923 2892 DO jj = 1, ijpj 2924 2893 DO ji = ildi, ilei … … 2928 2897 ENDIF 2929 2898 END DO 2930 IF 2899 IF(l_isend) THEN 2931 2900 DO jr = 1,nsndto 2932 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN2901 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 2933 2902 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2934 2903 ENDIF … … 2948 2917 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2949 2918 ! 2950 ztab(:,:) = 0. e02919 ztab(:,:) = 0._wp 2951 2920 DO jr = 1, ndim_rank_north ! recover the global north array 2952 2921 iproc = nrank_north(jr) + 1 … … 2975 2944 END SUBROUTINE mpp_lbc_north_2d 2976 2945 2977 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 2946 2947 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, kfld ) 2978 2948 !!--------------------------------------------------------------------- 2979 2949 !! *** routine mpp_lbc_north_2d *** … … 2990 2960 !! 2991 2961 !!---------------------------------------------------------------------- 2992 INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d 2993 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 2994 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2995 ! ! = T , U , V , F or W gridpoints 2996 REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2997 !! ! = 1. , the sign is kept 2962 TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields 2963 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2964 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold 2965 INTEGER , INTENT(in ) :: kfld ! number of variables contained in pt2d 2966 ! 2998 2967 INTEGER :: ji, jj, jr, jk 2999 2968 INTEGER :: ierr, itaille, ildi, ilei, iilb 3000 INTEGER :: ijpj, ijpjm1, ij, iproc 3001 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 3002 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 3003 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 3004 ! ! Workspace for message transfers avoiding mpi_allgather 2969 INTEGER :: ijpj, ijpjm1, ij, iproc, iflag 2970 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 2971 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2972 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2973 ! ! Workspace for message transfers avoiding mpi_allgather 2974 INTEGER :: istatus(mpi_status_size) 3005 2975 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab 3006 2976 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 3007 2977 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 3008 2978 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 3009 INTEGER :: istatus(mpi_status_size) 3010 INTEGER :: iflag 3011 !!---------------------------------------------------------------------- 3012 ! 3013 ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), & 3014 & znorthgloio(jpi,4,num_fields,jpni) ) ! expanded to 3 dimensions 3015 ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 2979 !!---------------------------------------------------------------------- 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) ) 3016 2984 ! 3017 2985 ijpj = 4 … … 3019 2987 ! 3020 2988 3021 DO jk = 1, num_fields2989 DO jk = 1, kfld 3022 2990 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable) 3023 2991 ij = jj - nlcj + ijpj … … 3033 3001 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 3034 3002 ! 3035 ztabr(:,:,:) = 0 3036 ztabl(:,:,:) = 0 3037 3038 DO jk = 1, num_fields3003 ztabr(:,:,:) = 0._wp 3004 ztabl(:,:,:) = 0._wp 3005 3006 DO jk = 1, kfld 3039 3007 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 3040 3008 ij = jj - nlcj + ijpj … … 3045 3013 END DO 3046 3014 3047 DO jr = 1, nsndto3048 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN3049 CALL mppsend(5, znorthloc, itaille* num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times3015 DO jr = 1, nsndto 3016 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 3017 CALL mppsend(5, znorthloc, itaille*kfld, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "kfld" times 3050 3018 ENDIF 3051 3019 END DO 3052 DO jr = 1, nsndto3020 DO jr = 1, nsndto 3053 3021 iproc = nfipproc(isendto(jr),jpnj) 3054 IF( iproc .ne. -1) THEN3022 IF( iproc /= -1 ) THEN 3055 3023 ilei = nleit (iproc+1) 3056 3024 ildi = nldit (iproc+1) 3057 3025 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 3058 3026 ENDIF 3059 IF( (iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN3060 CALL mpprecv(5, zfoldwk, itaille* num_fields, iproc) ! Buffer expanded "num_fields" times3061 DO jk = 1 , num_fields3027 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 3028 CALL mpprecv(5, zfoldwk, itaille*kfld, iproc) ! Buffer expanded "kfld" times 3029 DO jk = 1 , kfld 3062 3030 DO jj = 1, ijpj 3063 3031 DO ji = ildi, ilei … … 3066 3034 END DO 3067 3035 END DO 3068 ELSE IF (iproc .eq. (narea-1)) THEN3069 DO jk = 1, num_fields3036 ELSEIF ( iproc == narea-1 ) THEN 3037 DO jk = 1, kfld 3070 3038 DO jj = 1, ijpj 3071 3039 DO ji = ildi, ilei … … 3076 3044 ENDIF 3077 3045 END DO 3078 IF (l_isend) THEN3079 DO jr = 1, nsndto3080 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN3046 IF( l_isend ) THEN 3047 DO jr = 1, nsndto 3048 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 3081 3049 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 3082 3050 ENDIF … … 3084 3052 ENDIF 3085 3053 ! 3086 DO ji = 1, num_fields! Loop to manage 3D variables3054 DO ji = 1, kfld ! Loop to manage 3D variables 3087 3055 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 3088 3056 END DO 3089 3057 ! 3090 DO jk = 1, num_fields3058 DO jk = 1, kfld 3091 3059 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 3092 3060 ij = jj - nlcj + ijpj … … 3100 3068 ELSE 3101 3069 ! 3102 CALL MPI_ALLGATHER( znorthloc , itaille* num_fields, MPI_DOUBLE_PRECISION, &3103 & znorthgloio, itaille* num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr )3104 ! 3105 ztab(:,:,:) = 0. e03106 DO jk = 1, num_fields3070 CALL MPI_ALLGATHER( znorthloc , itaille*kfld, MPI_DOUBLE_PRECISION, & 3071 & znorthgloio, itaille*kfld, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 3072 ! 3073 ztab(:,:,:) = 0._wp 3074 DO jk = 1, kfld 3107 3075 DO jr = 1, ndim_rank_north ! recover the global north array 3108 3076 iproc = nrank_north(jr) + 1 … … 3118 3086 END DO 3119 3087 3120 DO ji = 1, num_fields3088 DO ji = 1, kfld 3121 3089 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 3122 3090 END DO 3123 3091 ! 3124 DO jk = 1, num_fields3092 DO jk = 1, kfld 3125 3093 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 3126 3094 ij = jj - nlcj + ijpj … … 3138 3106 END SUBROUTINE mpp_lbc_north_2d_multiple 3139 3107 3108 3140 3109 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 3141 3110 !!--------------------------------------------------------------------- … … 3155 3124 REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo 3156 3125 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 3157 ! ! = T , U , V , F or W -points 3158 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 3159 !! ! north fold, = 1. otherwise 3126 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 3127 ! 3160 3128 INTEGER :: ji, jj, jr 3161 3129 INTEGER :: ierr, itaille, ildi, ilei, iilb 3162 3130 INTEGER :: ijpj, ij, iproc 3163 !3164 3131 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 3165 3132 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 3166 3167 3133 !!---------------------------------------------------------------------- 3168 3134 ! 3169 3135 ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 3170 3171 3136 ! 3172 3137 ijpj=4 3173 ztab_e(:,:) = 0. e03174 3175 ij =03138 ztab_e(:,:) = 0._wp 3139 3140 ij = 0 3176 3141 ! put in znorthloc_e the last 4 jlines of pt2d 3177 3142 DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 3178 3143 ij = ij + 1 3179 3144 DO ji = 1, jpi 3180 znorthloc_e(ji,ij) =pt2d(ji,jj)3145 znorthloc_e(ji,ij) = pt2d(ji,jj) 3181 3146 END DO 3182 3147 END DO 3183 3148 ! 3184 3149 itaille = jpi * ( ijpj + 2 * jpr2dj ) 3185 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &3150 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 3186 3151 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 3187 3152 ! 3188 3153 DO jr = 1, ndim_rank_north ! recover the global north array 3189 3154 iproc = nrank_north(jr) + 1 3190 ildi = nldit (iproc)3191 ilei = nleit (iproc)3192 iilb = nimppt(iproc)3155 ildi = nldit (iproc) 3156 ilei = nleit (iproc) 3157 iilb = nimppt(iproc) 3193 3158 DO jj = 1, ijpj+2*jpr2dj 3194 3159 DO ji = ildi, ilei … … 3197 3162 END DO 3198 3163 END DO 3199 3200 3164 3201 3165 ! 2. North-Fold boundary conditions … … 3238 3202 !! 3239 3203 !!---------------------------------------------------------------------- 3240 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3241 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 3242 ! ! = T , U , V , F , W points 3243 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 3244 ! ! = 1. , the sign is kept 3245 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3204 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3205 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab grid point 3206 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 3207 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3246 3208 ! 3247 3209 INTEGER :: ji, jj, jk, jl ! dummy loop indices 3210 INTEGER :: ipk ! 3rd dimension of the input array 3248 3211 INTEGER :: imigr, iihom, ijhom ! local integers 3249 3212 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend … … 3255 3218 !!---------------------------------------------------------------------- 3256 3219 ! 3257 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 3258 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 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) ) 3259 3224 3260 3225 zland = 0._wp … … 3263 3228 ! ------------------------------ 3264 3229 ! ! East-West boundaries 3265 ! !* Cyclic east-west3230 ! !* Cyclic 3266 3231 IF( nbondi == 2) THEN 3267 3232 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN … … 3273 3238 ENDIF 3274 3239 ELSEIF(nbondi == -1) THEN 3275 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point3240 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 3276 3241 ELSEIF(nbondi == 1) THEN 3277 3242 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north … … 3298 3263 ! 3299 3264 ! ! Migrations 3300 imigr = jpreci * jpj * jpk3265 imigr = jpreci * jpj * ipk 3301 3266 ! 3302 3267 SELECT CASE ( nbondi_bdy(ib_bdy) ) … … 3348 3313 END DO 3349 3314 END SELECT 3350 3351 3315 3352 3316 ! 3. North and south directions … … 3363 3327 ! 3364 3328 ! ! Migrations 3365 imigr = jprecj * jpi * jpk3329 imigr = jprecj * jpi * ipk 3366 3330 ! 3367 3331 SELECT CASE ( nbondj_bdy(ib_bdy) ) … … 3413 3377 END DO 3414 3378 END SELECT 3415 3416 3379 3417 3380 ! 4. north fold treatment … … 3453 3416 !! 3454 3417 !!---------------------------------------------------------------------- 3455 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3456 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 3457 ! ! = T , U , V , F , W points 3458 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 3459 ! ! = 1. , the sign is kept 3460 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3461 ! 3462 INTEGER :: ji, jj, jl ! dummy loop indices 3418 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3419 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3420 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 3421 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3422 ! 3423 INTEGER :: ji, jj, jl ! dummy loop indices 3463 3424 INTEGER :: imigr, iihom, ijhom ! local integers 3464 3425 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend … … 3478 3439 ! ------------------------------ 3479 3440 ! ! East-West boundaries 3480 ! !* Cyclic east-west3441 ! !* Cyclic 3481 3442 IF( nbondi == 2 ) THEN 3482 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN3443 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 3483 3444 ptab( 1 ,:) = ptab(jpim1,:) 3484 3445 ptab(jpi,:) = ptab( 2 ,:) 3485 3446 ELSE 3486 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point3487 ptab(nlci-jpreci+1:jpi ,:) = zland ! north3447 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3448 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3488 3449 ENDIF 3489 3450 ELSEIF(nbondi == -1) THEN 3490 IF( .NOT.cd_type == 'F' )ptab( 1 :jpreci,:) = zland ! south except F-point3451 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3491 3452 ELSEIF(nbondi == 1) THEN 3492 ptab(nlci-jpreci+1:jpi ,:) = zland ! north3453 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3493 3454 ENDIF 3494 3455 ! !* closed … … 3537 3498 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3538 3499 CASE ( -1 ) 3539 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3540 CASE ( 0 ) 3541 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3542 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )3543 CASE ( 1 ) 3544 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )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 ) 3545 3506 END SELECT 3546 3507 ! … … 3602 3563 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3603 3564 CASE ( -1 ) 3604 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err)3605 CASE ( 0 ) 3606 IF(l_isend) CALL mpi_wait (ml_req1, ml_stat, ml_err)3607 IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err)3608 CASE ( 1 ) 3609 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err)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 ) 3610 3571 END SELECT 3611 3572 ! … … 3628 3589 END DO 3629 3590 END SELECT 3630 3631 3591 3632 3592 ! 4. north fold treatment … … 3713 3673 !! This subroutine computes yddb(i) = ydda(i)+yddb(i) 3714 3674 !!--------------------------------------------------------------------- 3715 INTEGER , INTENT(in) ::ilen, itype3716 COMPLEX(wp), DIMENSION(ilen), INTENT(in) ::ydda3717 COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::yddb3675 INTEGER , INTENT(in) :: ilen, itype 3676 COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda 3677 COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb 3718 3678 ! 3719 3679 REAL(wp) :: zerr, zt1, zt2 ! local work variables 3720 INTEGER :: ji, ztmp ! local scalar 3680 INTEGER :: ji, ztmp ! local scalar 3681 !!--------------------------------------------------------------------- 3721 3682 3722 3683 ztmp = itype ! avoid compilation warning … … 3841 3802 !! nono : number for local neighboring processors 3842 3803 !!---------------------------------------------------------------------- 3804 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 3805 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3806 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 3843 3807 INTEGER , INTENT(in ) :: jpri 3844 3808 INTEGER , INTENT(in ) :: jprj 3845 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 3846 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3847 ! ! = T , U , V , F , W and I points 3848 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the 3849 !! ! north boundary, = 1. otherwise 3809 ! 3850 3810 INTEGER :: jl ! dummy loop indices 3851 3811 INTEGER :: imigr, iihom, ijhom ! temporary integers … … 3875 3835 ! 3876 3836 ELSE !* closed 3877 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0. e0! south except at F-point3878 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0. e0! north3837 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point 3838 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north 3879 3839 ENDIF 3880 3840 ! … … 3996 3956 END DO 3997 3957 END SELECT 3998 3958 ! 3999 3959 END SUBROUTINE mpp_lnk_2d_icb 4000 3960 … … 4020 3980 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 4021 3981 END INTERFACE 3982 INTERFACE mpp_max_multiple 3983 MODULE PROCEDURE mppmax_real_multiple 3984 END INTERFACE 4022 3985 4023 3986 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag … … 4191 4154 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 4192 4155 END SUBROUTINE mpp_comm_free 4156 4157 SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom ) 4158 REAL, DIMENSION(:) :: ptab ! 4159 INTEGER :: kdim ! 4160 INTEGER, OPTIONAL :: kcom ! 4161 WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim 4162 END SUBROUTINE mppmax_real_multiple 4163 4193 4164 #endif 4194 4165 … … 4225 4196 CALL FLUSH(numout ) 4226 4197 IF( numstp /= -1 ) CALL FLUSH(numstp ) 4227 IF( num sol /= -1 ) CALL FLUSH(numsol)4198 IF( numrun /= -1 ) CALL FLUSH(numrun ) 4228 4199 IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice) 4229 4200 ! … … 4332 4303 WRITE(kout,*) 4333 4304 ENDIF 4334 CALL FLUSH( kout)4305 CALL FLUSH( kout ) 4335 4306 STOP 'ctl_opn bad opening' 4336 4307 ENDIF -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r7761 r7904 622 622 ! 623 623 IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file 624 IF( num sol /= -1 ) CLOSE( numsol ) ! solverfile624 IF( numrun /= -1 ) CLOSE( numrun ) ! run statistics file 625 625 IF( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist 626 626 IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist -
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/stpctl.F90
r7852 r7904 9 9 !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module 10 10 !! 2.0 ! 2009-07 (G. Madec) Add statistic for time-spliting 11 !! 3.7 ! 2016-09 (G. Madec) Remove solver 12 !! 4.0 ! 2017-04 (G. Madec) regroup global communications 11 13 !!---------------------------------------------------------------------- 12 14 … … 21 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 22 24 USE lib_mpp ! distributed memory computing 23 USE lib_fortran ! Fortran routines library24 25 25 26 IMPLICIT NONE … … 28 29 PUBLIC stp_ctl ! routine called by step.F90 29 30 !!---------------------------------------------------------------------- 30 !! NEMO/OPA 3.3 , NEMO Consortium (2010)31 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 31 32 !! $Id$ 32 33 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 42 43 !! ** Method : - Save the time step in numstp 43 44 !! - Print it each 50 time steps 44 !! - Stop the run IF problem ( indic < 0 ) 45 !! - Stop the run IF problem encountered by setting indic=-3 46 !! Problems checked: |ssh| maximum larger than 10 m 47 !! |U| maximum larger than 10 m/s 48 !! negative sea surface salinity 45 49 !! 46 !! ** Actions : 'time.step' file containing thelast ocean time-step47 !! 50 !! ** Actions : "time.step" file = last ocean time-step 51 !! "run.stat" file = run statistics 48 52 !!---------------------------------------------------------------------- 49 53 INTEGER, INTENT(in ) :: kt ! ocean time-step index … … 51 55 !! 52 56 INTEGER :: ji, jj, jk ! dummy loop indices 53 INTEGER :: ii, ij, ik ! local integers 54 REAL(wp) :: zumax, zsmin, zssh2, zsshmax ! local scalars 55 INTEGER, DIMENSION(3) :: ilocu ! 56 INTEGER, DIMENSION(2) :: ilocs ! 57 INTEGER :: iih, ijh ! local integers 58 INTEGER :: iiu, iju, iku ! - - 59 INTEGER :: iis, ijs ! - - 60 REAL(wp) :: zzz ! local real 61 INTEGER , DIMENSION(3) :: ilocu 62 INTEGER , DIMENSION(2) :: ilocs, iloch 63 REAL(wp), DIMENSION(3) :: zmax 57 64 !!---------------------------------------------------------------------- 58 65 ! … … 61 68 WRITE(numout,*) 'stp_ctl : time-stepping control' 62 69 WRITE(numout,*) '~~~~~~~' 63 ! open time.step file70 ! ! open time.step file 64 71 CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 72 ! ! open run.stat file 73 CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 65 74 ENDIF 66 75 ! 67 IF(lwp) WRITE ( numstp, '(1x, i8)' ) kt !* save the current time step in numstp 68 IF(lwp) REWIND( numstp ) ! -------------------------- 76 IF(lwp) THEN !== current time step ==! ("time.step" file) 77 WRITE ( numstp, '(1x, i8)' ) kt 78 REWIND( numstp ) 79 ENDIF 69 80 ! 70 ! !* Test maximum of velocity (zonal only) 71 ! ! ------------------------ 72 !! zumax = MAXVAL( ABS( un(:,:,:) ) ) ! slower than the following loop on NEC SX5 73 zumax = 0.e0 74 DO jk = 1, jpk 75 DO jj = 1, jpj 76 DO ji = 1, jpi 77 zumax = MAX(zumax,ABS(un(ji,jj,jk))) 78 END DO 79 END DO 80 END DO 81 IF( lk_mpp ) CALL mpp_max( zumax ) ! max over the global domain 81 ! !== test of extrema ==! 82 zmax(1) = MAXVAL( ABS( sshn(:,:) ) ) ! ssh max 83 zmax(2) = MAXVAL( ABS( un(:,:,:) ) ) ! velocity max (zonal only) 84 zmax(3) = MAXVAL( -tsn(:,:,1,jp_sal) , mask = tmask(:,:,1) == 1._wp ) ! minus surface salinity max 82 85 ! 83 IF( MOD( kt, nwrite ) == 1 .AND. lwp ) WRITE(numout,*) ' ==>> time-step= ',kt,' abs(U) max: ', zumax86 IF( lk_mpp ) CALL mpp_max_multiple( zmax(:), 3 ) ! max over the global domain 84 87 ! 85 IF( zumax > 20.e0 ) THEN 88 IF( MOD( kt, nwrite ) == 1 .AND. lwp ) THEN 89 WRITE(numout,*) ' ==>> time-step= ',kt,' |U| max: ', zmax(1), ' SSS min:', - zmax(2) 90 ENDIF 91 ! 92 IF ( zmax(1) > 10._wp .OR. & ! too large sea surface height ( > 10 m) 93 & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) 94 & zmax(3) > 0._wp ) THEN ! negative sea surface salinity 86 95 IF( lk_mpp ) THEN 87 CALL mpp_maxloc(ABS(un),umask,zumax,ii,ij,ik) 96 CALL mpp_maxloc( ABS(sshn) , tmask(:,:,1), zzz, iih, ijh ) 97 CALL mpp_maxloc( ABS(un) , umask , zzz, iiu, iju, iku ) 98 CALL mpp_minloc( tsn(:,:,1,jp_sal), tmask(:,:,1), zzz, iis, ijs ) 88 99 ELSE 100 iloch = MINLOC( ABS( sshn(:,:) ) ) 89 101 ilocu = MAXLOC( ABS( un(:,:,:) ) ) 90 ii = ilocu(1) + nimpp - 1 91 ij = ilocu(2) + njmpp - 1 92 ik = ilocu(3) 102 ilocs = MINLOC( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1._wp ) 103 iih = iloch(1) + nimpp - 1 ; ijh = iloch(2) + njmpp - 1 104 iiu = ilocu(1) + nimpp - 1 ; iju = ilocu(2) + njmpp - 1 ; iku = ilocu(3) 105 iis = ilocs(1) + nimpp - 1 ; ijs = ilocs(2) + njmpp - 1 93 106 ENDIF 94 107 IF(lwp) THEN 95 108 WRITE(numout,cform_err) 96 WRITE(numout,*) ' stpctl: the zonal velocity is larger than 20 m/s'109 WRITE(numout,*) ' stpctl: |ssh| > 10 m or |U| > 10 m/s or SSS < 0' 97 110 WRITE(numout,*) ' ====== ' 98 WRITE(numout,9400) kt, zumax, ii, ij, ik 111 WRITE(numout,9100) kt, zmax(1), iih, ijh 112 WRITE(numout,9200) kt, zmax(2), iiu, iju, iku 113 WRITE(numout,9300) kt, - zmax(3), iis, ijs 99 114 WRITE(numout,*) 100 WRITE(numout,*) ' output of last fields in numwso'115 WRITE(numout,*) ' output of last computed fields in output.abort.nc file' 101 116 ENDIF 102 117 kindic = -3 103 118 ENDIF 104 9400 FORMAT (' kt=',i6,' max abs(U): ',1pg11.4,', i j k: ',3i5) 119 9100 FORMAT (' kt=',i8,' |ssh| max: ',1pg11.4,', at i j : ',2i5) 120 9200 FORMAT (' kt=',i8,' |U| max: ',1pg11.4,', at i j k: ',3i5) 121 9300 FORMAT (' kt=',i8,' SSS min: ',1pg11.4,', at i j : ',2i5) 105 122 ! 106 ! !* Test minimum of salinity 107 ! ! ------------------------ 108 !! zsmin = MINVAL( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1.e0 ) slower than the following loop on NEC SX5 109 zsmin = 100._wp 110 DO jj = 2, jpjm1 111 DO ji = 1, jpi 112 IF( tmask(ji,jj,1) == 1) zsmin = MIN(zsmin,tsn(ji,jj,1,jp_sal)) 113 END DO 114 END DO 115 IF( lk_mpp ) CALL mpp_min( zsmin ) ! min over the global domain 123 ! !== run statistics ==! ("run.stat" file) 124 IF(lwp) WRITE(numrun,9400) kt, zmax(1), zmax(2), - zmax(3) 116 125 ! 117 IF( MOD( kt, nwrite ) == 1 .AND. lwp ) WRITE(numout,*) ' ==>> time-step= ',kt,' SSS min:', zsmin 118 ! 119 IF( zsmin < 0.) THEN 120 IF (lk_mpp) THEN 121 CALL mpp_minloc ( tsn(:,:,1,jp_sal),tmask(:,:,1), zsmin, ii,ij ) 122 ELSE 123 ilocs = MINLOC( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1.e0 ) 124 ii = ilocs(1) + nimpp - 1 125 ij = ilocs(2) + njmpp - 1 126 ENDIF 127 ! 128 IF(lwp) THEN 129 WRITE(numout,cform_err) 130 WRITE(numout,*) 'stp_ctl : NEGATIVE sea surface salinity' 131 WRITE(numout,*) '======= ' 132 WRITE(numout,9500) kt, zsmin, ii, ij 133 WRITE(numout,*) 134 WRITE(numout,*) ' output of last fields in numwso' 135 ENDIF 136 kindic = -3 137 ENDIF 138 9500 FORMAT (' kt=',i6,' min SSS: ',1pg11.4,', i j: ',2i5) 139 ! 140 ! 141 IF( lk_c1d ) RETURN ! No log file in case of 1D vertical configuration 142 143 ! log file (ssh statistics) 144 ! -------- !* ssh statistics (and others...) 145 IF( kt == nit000 .AND. lwp ) THEN ! open ssh statistics file (put in solver.stat file) 146 CALL ctl_opn( numsol, 'solver.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 147 ENDIF 148 ! 149 zsshmax = 0.e0 150 DO jj = 1, jpj 151 DO ji = 1, jpi 152 IF( tmask(ji,jj,1) == 1) zsshmax = MAX( zsshmax, ABS(sshn(ji,jj)) ) 153 END DO 154 END DO 155 IF( lk_mpp ) CALL mpp_max( zsshmax ) ! min over the global domain 156 ! 157 IF( MOD( kt, nwrite ) == 1 .AND. lwp ) WRITE(numout,*) ' ==>> time-step= ',kt,' ssh max:', zsshmax 158 ! 159 IF( zsshmax > 10.e0 ) THEN 160 IF (lk_mpp) THEN 161 CALL mpp_maxloc( ABS(sshn(:,:)),tmask(:,:,1),zsshmax,ii,ij) 162 ELSE 163 ilocs = MAXLOC( ABS(sshn(:,:)) ) 164 ii = ilocs(1) + nimpp - 1 165 ij = ilocs(2) + njmpp - 1 166 ENDIF 167 ! 168 IF(lwp) THEN 169 WRITE(numout,cform_err) 170 WRITE(numout,*) 'stp_ctl : the ssh is larger than 10m' 171 WRITE(numout,*) '======= ' 172 WRITE(numout,9600) kt, zsshmax, ii, ij 173 WRITE(numout,*) 174 WRITE(numout,*) ' output of last fields in numwso' 175 ENDIF 176 kindic = -3 177 ENDIF 178 9600 FORMAT (' kt=',i6,' max ssh: ',1pg11.4,', i j: ',2i5) 179 ! 180 zssh2 = glob_sum( sshn(:,:) * sshn(:,:) ) 181 ! 182 IF(lwp) WRITE(numsol,9700) kt, zssh2, zumax, zsmin ! ssh statistics 183 ! 184 9700 FORMAT(' it :', i8, ' ssh2: ', d23.16, ' Umax: ',d23.16,' Smin: ',d23.16) 126 9400 FORMAT(' it :', i8, ' |ssh|_max: ', e16.10, ' |U|_max: ',e16.10,' SSS_min: ',e16.10) 185 127 ! 186 128 END SUBROUTINE stp_ctl
Note: See TracChangeset
for help on using the changeset viewer.