- Timestamp:
- 2017-04-13T09:10:07+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
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
Note: See TracChangeset
for help on using the changeset viewer.
