- Timestamp:
- 2017-12-01T18:44:09+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r8114 r8882 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 7 7 !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module 8 8 !! 3.2 ! 2009-03 (R. Benshila) External north fold treatment 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 10 10 !! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case 11 11 !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi 12 !! 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) 14 !! - ! 2017-05 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 12 15 !!---------------------------------------------------------------------- 13 16 #if defined key_mpp_mpi … … 15 18 !! 'key_mpp_mpi' MPI massively parallel processing library 16 19 !!---------------------------------------------------------------------- 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 21 !!---------------------------------------------------------------------- 20 !! define the generic interfaces of lib_mpp routines 21 !!---------------------------------------------------------------------- 22 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_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 25 !!---------------------------------------------------------------------- 26 USE par_oce ! ocean dynamics and tracers 22 27 USE lib_mpp ! distributed memory computing library 23 28 USE lbcnfd ! north fold 29 30 INTERFACE lbc_lnk 31 MODULE PROCEDURE mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 32 END INTERFACE 33 INTERFACE lbc_lnk_ptr 34 MODULE PROCEDURE mpp_lnk_2d_ptr , mpp_lnk_3d_ptr , mpp_lnk_4d_ptr 35 END INTERFACE 24 36 INTERFACE lbc_lnk_multi 25 MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 26 END INTERFACE 27 ! 28 INTERFACE lbc_lnk 29 MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 30 END INTERFACE 31 ! 32 INTERFACE lbc_sum 33 MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 37 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 34 38 END INTERFACE 35 39 ! … … 46 50 END INTERFACE 47 51 48 PUBLIC lbc_lnk ! ocean lateral boundary conditions 49 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 50 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_lnk_e ! extended ocean/ice lateral boundary conditions 52 55 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 53 PUBLIC lbc_lnk_icb ! 54 55 !!---------------------------------------------------------------------- 56 !! NEMO/OPA 3.3 , NEMO Consortium (2010)56 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 57 58 !!---------------------------------------------------------------------- 59 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 57 60 !! $Id$ 58 61 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 59 62 !!---------------------------------------------------------------------- 63 CONTAINS 64 60 65 #else 61 66 !!---------------------------------------------------------------------- 62 67 !! Default option shared memory computing 63 68 !!---------------------------------------------------------------------- 64 !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d 69 !! routines setting the appropriate values 70 !! on first and last row and column of the global domain 71 !!---------------------------------------------------------------------- 65 72 !! lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 66 73 !! lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh … … 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 … … 79 86 80 87 INTERFACE lbc_lnk 81 MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d 82 END INTERFACE 83 ! 84 INTERFACE lbc_sum 85 MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 86 END INTERFACE 87 88 MODULE PROCEDURE lbc_lnk_2d , lbc_lnk_3d , lbc_lnk_4d 89 END INTERFACE 90 INTERFACE lbc_lnk_ptr 91 MODULE PROCEDURE lbc_lnk_2d_ptr , lbc_lnk_3d_ptr , lbc_lnk_4d_ptr 92 END INTERFACE 93 INTERFACE lbc_lnk_multi 94 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 95 END INTERFACE 96 ! 88 97 INTERFACE lbc_lnk_e 89 98 MODULE PROCEDURE lbc_lnk_2d_e 90 99 END INTERFACE 91 100 ! 92 INTERFACE lbc_lnk_multi93 MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple94 END INTERFACE95 96 101 INTERFACE lbc_bdy_lnk 97 102 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 102 107 END INTERFACE 103 108 104 TYPE arrayptr105 REAL , DIMENSION (:,:), POINTER :: pt2d106 END TYPE arrayptr107 PUBLIC arrayptr108 109 109 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 110 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 conditions 110 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions 111 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 113 112 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 114 PUBLIC lbc_lnk_icb ! 115 116 !!---------------------------------------------------------------------- 117 !! NEMO/OPA 3.7 , NEMO Consortium (2015)113 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 114 115 !!---------------------------------------------------------------------- 116 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 118 117 !! $Id$ 119 118 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 122 121 123 122 # if defined key_c1d 124 !! ----------------------------------------------------------------------123 !!====================================================================== 125 124 !! 'key_c1d' 1D configuration 126 !!---------------------------------------------------------------------- 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 125 !!====================================================================== 126 !! central point value replicated over the 8 surrounding points 127 !!---------------------------------------------------------------------- 146 128 147 129 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) … … 153 135 !! ** Method : 1D case, the central water column is set everywhere 154 136 !!---------------------------------------------------------------------- 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) 137 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 138 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 139 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 140 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 141 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 160 142 ! 161 143 INTEGER :: jk ! dummy loop index … … 163 145 !!---------------------------------------------------------------------- 164 146 ! 165 DO jk = 1, jpk147 DO jk = 1, SIZE( pt3d, 3 ) 166 148 ztab = pt3d(2,2,jk) 167 149 pt3d(:,:,jk) = ztab … … 179 161 !! ** Method : 1D case, the central water column is set everywhere 180 162 !!---------------------------------------------------------------------- 163 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 181 164 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 165 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 184 166 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 185 167 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) … … 193 175 END SUBROUTINE lbc_lnk_2d 194 176 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( pt2dB, cd_typeB, psgnB )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 177 #else 253 !! ----------------------------------------------------------------------178 !!====================================================================== 254 179 !! Default option 3D shared memory computing 255 !!---------------------------------------------------------------------- 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) 262 !! 263 !! ** Method : psign = -1 : change the sign across the north fold 264 !! = 1 : no change of the sign across the north fold 265 !! = 0 : no change of the sign across the north fold and 266 !! strict positivity preserved: use inner row/column 267 !! for closed boundaries. 268 !!---------------------------------------------------------------------- 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 !! 298 REAL(wp) :: zland 299 !!---------------------------------------------------------------------- 300 301 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 302 ELSE ; zland = 0._wp 303 ENDIF 304 305 306 IF( PRESENT( cd_mpp ) ) THEN 307 ! only fill the overlap area and extra allows 308 ! this is in mpp case. In this module, just do nothing 309 ELSE 310 ! ! East-West boundaries 311 ! ! ====================== 312 SELECT CASE ( nperio ) 313 ! 314 CASE ( 1 , 4 , 6 ) !** cyclic east-west 315 pt3d( 1 ,:,:) = pt3d(jpim1,:,:) ! all points 316 pt3d(jpi,:,:) = pt3d( 2 ,:,:) 317 ! 318 CASE DEFAULT !** East closed -- West closed 319 SELECT CASE ( cd_type ) 320 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 321 pt3d( 1 ,:,:) = zland 322 pt3d(jpi,:,:) = zland 323 CASE ( 'F' ) ! F-point 324 pt3d(jpi,:,:) = zland 325 END SELECT 326 ! 327 END SELECT 328 ! ! North-South boundaries 329 ! ! ====================== 330 SELECT CASE ( nperio ) 331 ! 332 CASE ( 2 ) !** South symmetric -- North closed 333 SELECT CASE ( cd_type ) 334 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 335 pt3d(:, 1 ,:) = pt3d(:,3,:) 336 pt3d(:,jpj,:) = zland 337 CASE ( 'V' , 'F' ) ! V-, F-points 338 pt3d(:, 1 ,:) = psgn * pt3d(:,2,:) 339 pt3d(:,jpj,:) = zland 340 END SELECT 341 ! 342 CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed 343 SELECT CASE ( cd_type ) ! South : closed 344 CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point 345 pt3d(:, 1 ,:) = zland 346 END SELECT 347 ! ! North fold 348 CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn ) 349 ! 350 CASE DEFAULT !** North closed -- South closed 351 SELECT CASE ( cd_type ) 352 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 353 pt3d(:, 1 ,:) = zland 354 pt3d(:,jpj,:) = zland 355 CASE ( 'F' ) ! F-point 356 pt3d(:,jpj,:) = zland 357 END SELECT 358 ! 359 END SELECT 360 ! 361 ENDIF 362 ! 363 END SUBROUTINE lbc_lnk_3d 364 365 366 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 367 !!--------------------------------------------------------------------- 368 !! *** ROUTINE lbc_lnk_2d *** 369 !! 370 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case) 371 !! 372 !! ** Method : psign = -1 : change the sign across the north fold 373 !! = 1 : no change of the sign across the north fold 374 !! = 0 : no change of the sign across the north fold and 375 !! strict positivity preserved: use inner row/column 376 !! for closed boundaries. 377 !!---------------------------------------------------------------------- 378 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 379 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 sign 381 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 382 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 383 !! 384 REAL(wp) :: zland 385 !!---------------------------------------------------------------------- 386 387 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 388 ELSE ; zland = 0._wp 389 ENDIF 390 391 IF (PRESENT(cd_mpp)) THEN 392 ! only fill the overlap area and extra allows 393 ! this is in mpp case. In this module, just do nothing 394 ELSE 395 ! ! East-West boundaries 396 ! ! ==================== 397 SELECT CASE ( nperio ) 398 ! 399 CASE ( 1 , 4 , 6 ) !** cyclic east-west 400 pt2d( 1 ,:) = pt2d(jpim1,:) ! all points 401 pt2d(jpi,:) = pt2d( 2 ,:) 402 ! 403 CASE DEFAULT !** East closed -- West closed 404 SELECT CASE ( cd_type ) 405 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 406 pt2d( 1 ,:) = zland 407 pt2d(jpi,:) = zland 408 CASE ( 'F' ) ! F-point 409 pt2d(jpi,:) = zland 410 END SELECT 411 ! 412 END SELECT 413 ! ! North-South boundaries 414 ! ! ====================== 415 SELECT CASE ( nperio ) 416 ! 417 CASE ( 2 ) !** South symmetric -- North closed 418 SELECT CASE ( cd_type ) 419 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 420 pt2d(:, 1 ) = pt2d(:,3) 421 pt2d(:,jpj) = zland 422 CASE ( 'V' , 'F' ) ! V-, F-points 423 pt2d(:, 1 ) = psgn * pt2d(:,2) 424 pt2d(:,jpj) = zland 425 END SELECT 426 ! 427 CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed 428 SELECT CASE ( cd_type ) ! South : closed 429 CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point 430 pt2d(:, 1 ) = zland 431 END SELECT 432 ! ! North fold 433 CALL lbc_nfd( pt2d(:,:), cd_type, psgn ) 434 ! 435 CASE DEFAULT !** North closed -- South closed 436 SELECT CASE ( cd_type ) 437 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 438 pt2d(:, 1 ) = zland 439 pt2d(:,jpj) = zland 440 CASE ( 'F' ) ! F-point 441 pt2d(:,jpj) = zland 442 END SELECT 443 ! 444 END SELECT 445 ! 446 ENDIF 447 ! 448 END SUBROUTINE lbc_lnk_2d 449 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) ) 463 END DO 464 ! 465 END SUBROUTINE lbc_lnk_2d_multiple 466 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 473 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 474 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 477 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 478 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 481 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 482 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 483 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 484 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 485 !! 486 !!--------------------------------------------------------------------- 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( pt2dB, cd_typeB, psgnB ) 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 501 END SUBROUTINE lbc_lnk_2d_9 502 503 SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 504 !!--------------------------------------------------------------------- 505 !! *** ROUTINE lbc_lnk_sum_2d *** 506 !! 507 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case) 508 !! 509 !! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean 510 !! coupling if conservation option activated. As no ice shelf are present along 511 !! this line, nothing is done along the north fold. 512 !!---------------------------------------------------------------------- 513 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 514 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 sign 516 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 517 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 518 !! 519 REAL(wp) :: zland 520 !!---------------------------------------------------------------------- 521 522 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 523 ELSE ; zland = 0._wp 524 ENDIF 525 526 IF (PRESENT(cd_mpp)) THEN 527 ! only fill the overlap area and extra allows 528 ! this is in mpp case. In this module, just do nothing 529 ELSE 530 ! ! East-West boundaries 531 ! ! ==================== 532 SELECT CASE ( nperio ) 533 ! 534 CASE ( 1 , 4 , 6 ) !** cyclic east-west 535 pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:) 536 pt2d( 2 ,:) = pt2d( 2 ,:) + pt2d(jpi,:) 537 pt2d( 1 ,:) = 0.0_wp ! all points 538 pt2d(jpi,:) = 0.0_wp 539 ! 540 CASE DEFAULT !** East closed -- West closed 541 SELECT CASE ( cd_type ) 542 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 543 pt2d( 1 ,:) = zland 544 pt2d(jpi,:) = zland 545 CASE ( 'F' ) ! F-point 546 pt2d(jpi,:) = zland 547 END SELECT 548 ! 549 END SELECT 550 ! ! North-South boundaries 551 ! ! ====================== 552 ! Nothing to do for the north fold, there is no ice shelf along this line. 553 ! 554 END IF 555 556 END SUBROUTINE 557 558 SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 559 !!--------------------------------------------------------------------- 560 !! *** ROUTINE lbc_lnk_sum_3d *** 561 !! 562 !! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case) 563 !! 564 !! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean 565 !! coupling if conservation option activated. As no ice shelf are present along 566 !! this line, nothing is done along the north fold. 567 !!---------------------------------------------------------------------- 568 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 569 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 570 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 571 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 572 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 573 !! 574 REAL(wp) :: zland 575 !!---------------------------------------------------------------------- 576 577 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 578 ELSE ; zland = 0._wp 579 ENDIF 580 581 582 IF( PRESENT( cd_mpp ) ) THEN 583 ! only fill the overlap area and extra allows 584 ! this is in mpp case. In this module, just do nothing 585 ELSE 586 ! ! East-West boundaries 587 ! ! ====================== 588 SELECT CASE ( nperio ) 589 ! 590 CASE ( 1 , 4 , 6 ) !** cyclic east-west 591 pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 592 pt3d( 2 ,:,:) = pt3d( 2 ,:,:) + pt3d(jpi,:,:) 593 pt3d( 1 ,:,:) = 0.0_wp ! all points 594 pt3d(jpi,:,:) = 0.0_wp 595 ! 596 CASE DEFAULT !** East closed -- West closed 597 SELECT CASE ( cd_type ) 598 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 599 pt3d( 1 ,:,:) = zland 600 pt3d(jpi,:,:) = zland 601 CASE ( 'F' ) ! F-point 602 pt3d(jpi,:,:) = zland 603 END SELECT 604 ! 605 END SELECT 606 ! ! North-South boundaries 607 ! ! ====================== 608 ! Nothing to do for the north fold, there is no ice shelf along this line. 609 ! 610 END IF 611 END SUBROUTINE 612 613 180 !!====================================================================== 181 !! routines setting land point, or east-west cyclic, 182 !! or north-south cyclic, or north fold values 183 !! on first and last row and column of the global domain 184 !!---------------------------------------------------------------------- 185 186 !!---------------------------------------------------------------------- 187 !! *** routine lbc_lnk_(2,3,4)d *** 188 !! 189 !! * Argument : dummy argument use in lbc_lnk_... routines 190 !! ptab : array or pointer of arrays on which the boundary condition is applied 191 !! cd_nat : nature of array grid-points 192 !! psgn : sign used across the north fold boundary 193 !! kfld : optional, number of pt3d arrays 194 !! cd_mpp : optional, fill the overlap area only 195 !! pval : optional, background value (used at closed boundaries) 196 !!---------------------------------------------------------------------- 197 ! 198 ! !== 2D array and array of 2D pointer ==! 199 ! 200 # define DIM_2d 201 # define ROUTINE_LNK lbc_lnk_2d 202 # include "lbc_lnk_generic.h90" 203 # undef ROUTINE_LNK 204 # define MULTI 205 # define ROUTINE_LNK lbc_lnk_2d_ptr 206 # include "lbc_lnk_generic.h90" 207 # undef ROUTINE_LNK 208 # undef MULTI 209 # undef DIM_2d 210 ! 211 ! !== 3D array and array of 3D pointer ==! 212 ! 213 # define DIM_3d 214 # define ROUTINE_LNK lbc_lnk_3d 215 # include "lbc_lnk_generic.h90" 216 # undef ROUTINE_LNK 217 # define MULTI 218 # define ROUTINE_LNK lbc_lnk_3d_ptr 219 # include "lbc_lnk_generic.h90" 220 # undef ROUTINE_LNK 221 # undef MULTI 222 # undef DIM_3d 223 ! 224 ! !== 4D array and array of 4D pointer ==! 225 ! 226 # define DIM_4d 227 # define ROUTINE_LNK lbc_lnk_4d 228 # include "lbc_lnk_generic.h90" 229 # undef ROUTINE_LNK 230 # define MULTI 231 # define ROUTINE_LNK lbc_lnk_4d_ptr 232 # include "lbc_lnk_generic.h90" 233 # undef ROUTINE_LNK 234 # undef MULTI 235 # undef DIM_4d 236 614 237 #endif 615 238 239 !!====================================================================== 240 !! identical routines in both C1D and shared memory computing 241 !!====================================================================== 242 243 !!---------------------------------------------------------------------- 244 !! *** routine lbc_bdy_lnk_(2,3)d *** 245 !! 246 !! wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 247 !! to maintain the same interface with regards to the mpp case 248 !!---------------------------------------------------------------------- 249 616 250 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 used 621 !! to maintain the same interface with regards to the mpp case 622 !! 623 !!---------------------------------------------------------------------- 624 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 625 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 626 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 627 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 628 !!---------------------------------------------------------------------- 629 ! 251 !!---------------------------------------------------------------------- 252 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 253 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 254 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 255 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 256 !!---------------------------------------------------------------------- 630 257 CALL lbc_lnk_3d( pt3d, cd_type, psgn) 631 !632 258 END SUBROUTINE lbc_bdy_lnk_3d 633 259 634 260 635 261 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 used 640 !! to maintain the same interface with regards to the mpp case 641 !! 642 !!---------------------------------------------------------------------- 643 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 644 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied 645 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 646 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 647 !!---------------------------------------------------------------------- 648 ! 262 !!---------------------------------------------------------------------- 263 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied 264 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 265 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 266 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 267 !!---------------------------------------------------------------------- 649 268 CALL lbc_lnk_2d( pt2d, cd_type, psgn) 650 !651 269 END SUBROUTINE lbc_bdy_lnk_2d 652 270 653 271 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 case 660 !! 661 !! ** Method : psign = -1 : change the sign across the north fold 662 !! = 1 : no change of the sign across the north fold 663 !! = 0 : no change of the sign across the north fold and 664 !! strict positivity preserved: use inner row/column 665 !! for closed boundaries. 666 !!---------------------------------------------------------------------- 667 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 668 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 669 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 670 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 ! 272 !!gm This routine should be remove with an optional halos size added in orgument of generic routines 273 274 SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, ki, kj ) 275 !!---------------------------------------------------------------------- 276 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 277 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 278 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 279 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp) 280 !!---------------------------------------------------------------------- 674 281 CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 675 !676 282 END SUBROUTINE lbc_lnk_2d_e 283 !!gm end 677 284 678 285 #endif 679 286 680 287 !!====================================================================== 288 !! identical routines in both distributed and shared memory computing 289 !!====================================================================== 290 291 !!---------------------------------------------------------------------- 292 !! *** load_ptr_(2,3,4)d *** 293 !! 294 !! * Dummy Argument : 295 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 296 !! cd_nat ! nature of pt2d array grid-points 297 !! psgn ! sign used across the north fold boundary 298 !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers 299 !! cdna_ptr ! nature of ptab array grid-points 300 !! psgn_ptr ! sign used across the north fold boundary 301 !! kfld ! number of elements that has been attributed 302 !!---------------------------------------------------------------------- 303 304 !!---------------------------------------------------------------------- 305 !! *** lbc_lnk_(2,3,4)d_multi *** 306 !! *** load_ptr_(2,3,4)d *** 307 !! 308 !! * Argument : dummy argument use in lbc_lnk_multi_... routines 309 !! 310 !!---------------------------------------------------------------------- 311 312 # define DIM_2d 313 # define ROUTINE_MULTI lbc_lnk_2d_multi 314 # define ROUTINE_LOAD load_ptr_2d 315 # include "lbc_lnk_multi_generic.h90" 316 # undef ROUTINE_MULTI 317 # undef ROUTINE_LOAD 318 # undef DIM_2d 319 320 321 # define DIM_3d 322 # define ROUTINE_MULTI lbc_lnk_3d_multi 323 # define ROUTINE_LOAD load_ptr_3d 324 # include "lbc_lnk_multi_generic.h90" 325 # undef ROUTINE_MULTI 326 # undef ROUTINE_LOAD 327 # undef DIM_3d 328 329 330 # define DIM_4d 331 # define ROUTINE_MULTI lbc_lnk_4d_multi 332 # define ROUTINE_LOAD load_ptr_4d 333 # include "lbc_lnk_multi_generic.h90" 334 # undef ROUTINE_MULTI 335 # undef ROUTINE_LOAD 336 # undef DIM_4d 337 338 !!====================================================================== 681 339 END MODULE lbclnk 682 340
Note: See TracChangeset
for help on using the changeset viewer.