- Timestamp:
- 2017-12-13T15:58:53+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_merge_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r8114 r9019 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_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 24 !!---------------------------------------------------------------------- 25 USE par_oce ! ocean dynamics and tracers 22 26 USE lib_mpp ! distributed memory computing library 23 27 USE lbcnfd ! north fold 28 29 INTERFACE lbc_lnk 30 MODULE PROCEDURE mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 31 END INTERFACE 32 INTERFACE lbc_lnk_ptr 33 MODULE PROCEDURE mpp_lnk_2d_ptr , mpp_lnk_3d_ptr , mpp_lnk_4d_ptr 34 END INTERFACE 24 35 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 36 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 34 37 END INTERFACE 35 38 ! … … 38 41 END INTERFACE 39 42 ! 40 INTERFACE lbc_lnk_e41 MODULE PROCEDURE mpp_lnk_2d_e42 END INTERFACE43 !44 43 INTERFACE lbc_lnk_icb 45 44 MODULE PROCEDURE mpp_lnk_2d_icb 46 45 END INTERFACE 47 46 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 ! 47 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 48 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 52 49 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 53 PUBLIC lbc_lnk_icb ! 54 55 !!---------------------------------------------------------------------- 56 !! NEMO/OPA 3.3 , NEMO Consortium (2010)50 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 51 52 !!---------------------------------------------------------------------- 53 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 57 54 !! $Id$ 58 55 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 59 56 !!---------------------------------------------------------------------- 57 CONTAINS 58 60 59 #else 61 60 !!---------------------------------------------------------------------- 62 61 !! Default option shared memory computing 63 62 !!---------------------------------------------------------------------- 64 !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d 63 !! routines setting the appropriate values 64 !! on first and last row and column of the global domain 65 !!---------------------------------------------------------------------- 65 66 !! lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 66 67 !! lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh … … 70 71 !! lbc_bdy_lnk : set the lateral BDY boundary condition 71 72 !!---------------------------------------------------------------------- 72 USE oce 73 USE dom_oce 74 USE in_out_manager 75 USE lbcnfd 73 USE oce ! ocean dynamics and tracers 74 USE dom_oce ! ocean space and time domain 75 USE in_out_manager ! I/O manager 76 USE lbcnfd ! north fold 76 77 77 78 IMPLICIT NONE … … 79 80 80 81 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 INTERFACE lbc_lnk_e 89 MODULE PROCEDURE lbc_lnk_2d_e 90 END INTERFACE 91 ! 82 MODULE PROCEDURE lbc_lnk_2d , lbc_lnk_3d , lbc_lnk_4d 83 END INTERFACE 84 INTERFACE lbc_lnk_ptr 85 MODULE PROCEDURE lbc_lnk_2d_ptr , lbc_lnk_3d_ptr , lbc_lnk_4d_ptr 86 END INTERFACE 92 87 INTERFACE lbc_lnk_multi 93 MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple94 END INTERFACE 95 88 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 89 END INTERFACE 90 ! 96 91 INTERFACE lbc_bdy_lnk 97 92 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 99 94 ! 100 95 INTERFACE lbc_lnk_icb 101 MODULE PROCEDURE lbc_lnk_2d_e 102 END INTERFACE 103 104 TYPE arrayptr 105 REAL , DIMENSION (:,:), POINTER :: pt2d 106 END TYPE arrayptr 107 PUBLIC arrayptr 108 96 MODULE PROCEDURE lbc_lnk_2d_icb 97 END INTERFACE 98 109 99 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 100 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 113 101 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 114 PUBLIC lbc_lnk_icb ! 115 116 !!---------------------------------------------------------------------- 117 !! NEMO/OPA 3.7 , NEMO Consortium (2015)102 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 103 104 !!---------------------------------------------------------------------- 105 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 118 106 !! $Id$ 119 107 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 122 110 123 111 # if defined key_c1d 124 !! ----------------------------------------------------------------------112 !!====================================================================== 125 113 !! '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 114 !!====================================================================== 115 !! central point value replicated over the 8 surrounding points 116 !!---------------------------------------------------------------------- 146 117 147 118 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) … … 153 124 !! ** Method : 1D case, the central water column is set everywhere 154 125 !!---------------------------------------------------------------------- 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) 126 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 127 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 128 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 129 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 130 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 160 131 ! 161 132 INTEGER :: jk ! dummy loop index … … 163 134 !!---------------------------------------------------------------------- 164 135 ! 165 DO jk = 1, jpk136 DO jk = 1, SIZE( pt3d, 3 ) 166 137 ztab = pt3d(2,2,jk) 167 138 pt3d(:,:,jk) = ztab … … 179 150 !! ** Method : 1D case, the central water column is set everywhere 180 151 !!---------------------------------------------------------------------- 152 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 181 153 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 154 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 184 155 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 185 156 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) … … 193 164 END SUBROUTINE lbc_lnk_2d 194 165 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 166 #else 253 !! ----------------------------------------------------------------------167 !!====================================================================== 254 168 !! 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 169 !!====================================================================== 170 !! routines setting land point, or east-west cyclic, 171 !! or north-south cyclic, or north fold values 172 !! on first and last row and column of the global domain 173 !!---------------------------------------------------------------------- 174 175 !!---------------------------------------------------------------------- 176 !! *** routine lbc_lnk_(2,3,4)d *** 177 !! 178 !! * Argument : dummy argument use in lbc_lnk_... routines 179 !! ptab : array or pointer of arrays on which the boundary condition is applied 180 !! cd_nat : nature of array grid-points 181 !! psgn : sign used across the north fold boundary 182 !! kfld : optional, number of pt3d arrays 183 !! cd_mpp : optional, fill the overlap area only 184 !! pval : optional, background value (used at closed boundaries) 185 !!---------------------------------------------------------------------- 186 ! 187 ! !== 2D array and array of 2D pointer ==! 188 ! 189 # define DIM_2d 190 # define ROUTINE_LNK lbc_lnk_2d 191 # include "lbc_lnk_generic.h90" 192 # undef ROUTINE_LNK 193 # define MULTI 194 # define ROUTINE_LNK lbc_lnk_2d_ptr 195 # include "lbc_lnk_generic.h90" 196 # undef ROUTINE_LNK 197 # undef MULTI 198 # undef DIM_2d 199 ! 200 ! !== 3D array and array of 3D pointer ==! 201 ! 202 # define DIM_3d 203 # define ROUTINE_LNK lbc_lnk_3d 204 # include "lbc_lnk_generic.h90" 205 # undef ROUTINE_LNK 206 # define MULTI 207 # define ROUTINE_LNK lbc_lnk_3d_ptr 208 # include "lbc_lnk_generic.h90" 209 # undef ROUTINE_LNK 210 # undef MULTI 211 # undef DIM_3d 212 ! 213 ! !== 4D array and array of 4D pointer ==! 214 ! 215 # define DIM_4d 216 # define ROUTINE_LNK lbc_lnk_4d 217 # include "lbc_lnk_generic.h90" 218 # undef ROUTINE_LNK 219 # define MULTI 220 # define ROUTINE_LNK lbc_lnk_4d_ptr 221 # include "lbc_lnk_generic.h90" 222 # undef ROUTINE_LNK 223 # undef MULTI 224 # undef DIM_4d 225 614 226 #endif 615 227 228 !!====================================================================== 229 !! identical routines in both C1D and shared memory computing 230 !!====================================================================== 231 232 !!---------------------------------------------------------------------- 233 !! *** routine lbc_bdy_lnk_(2,3)d *** 234 !! 235 !! wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 236 !! to maintain the same interface with regards to the mpp case 237 !!---------------------------------------------------------------------- 238 616 239 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 ! 240 !!---------------------------------------------------------------------- 241 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 242 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 243 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 244 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 245 !!---------------------------------------------------------------------- 630 246 CALL lbc_lnk_3d( pt3d, cd_type, psgn) 631 !632 247 END SUBROUTINE lbc_bdy_lnk_3d 633 248 634 249 635 250 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 ! 251 !!---------------------------------------------------------------------- 252 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 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 !!---------------------------------------------------------------------- 649 257 CALL lbc_lnk_2d( pt2d, cd_type, psgn) 650 !651 258 END SUBROUTINE lbc_bdy_lnk_2d 652 259 653 260 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 ! 261 !!gm This routine should be removed with an optional halos size added in argument of generic routines 262 263 SUBROUTINE lbc_lnk_2d_icb( pt2d, cd_type, psgn, ki, kj ) 264 !!---------------------------------------------------------------------- 265 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 266 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 267 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 268 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp) 269 !!---------------------------------------------------------------------- 674 270 CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 675 !676 END SUBROUTINE lbc_lnk_2d_e 271 END SUBROUTINE lbc_lnk_2d_icb 272 !!gm end 677 273 678 274 #endif 679 275 680 276 !!====================================================================== 277 !! identical routines in both distributed and shared memory computing 278 !!====================================================================== 279 280 !!---------------------------------------------------------------------- 281 !! *** load_ptr_(2,3,4)d *** 282 !! 283 !! * Dummy Argument : 284 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 285 !! cd_nat ! nature of pt2d array grid-points 286 !! psgn ! sign used across the north fold boundary 287 !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers 288 !! cdna_ptr ! nature of ptab array grid-points 289 !! psgn_ptr ! sign used across the north fold boundary 290 !! kfld ! number of elements that has been attributed 291 !!---------------------------------------------------------------------- 292 293 !!---------------------------------------------------------------------- 294 !! *** lbc_lnk_(2,3,4)d_multi *** 295 !! *** load_ptr_(2,3,4)d *** 296 !! 297 !! * Argument : dummy argument use in lbc_lnk_multi_... routines 298 !! 299 !!---------------------------------------------------------------------- 300 301 # define DIM_2d 302 # define ROUTINE_MULTI lbc_lnk_2d_multi 303 # define ROUTINE_LOAD load_ptr_2d 304 # include "lbc_lnk_multi_generic.h90" 305 # undef ROUTINE_MULTI 306 # undef ROUTINE_LOAD 307 # undef DIM_2d 308 309 310 # define DIM_3d 311 # define ROUTINE_MULTI lbc_lnk_3d_multi 312 # define ROUTINE_LOAD load_ptr_3d 313 # include "lbc_lnk_multi_generic.h90" 314 # undef ROUTINE_MULTI 315 # undef ROUTINE_LOAD 316 # undef DIM_3d 317 318 319 # define DIM_4d 320 # define ROUTINE_MULTI lbc_lnk_4d_multi 321 # define ROUTINE_LOAD load_ptr_4d 322 # include "lbc_lnk_multi_generic.h90" 323 # undef ROUTINE_MULTI 324 # undef ROUTINE_LOAD 325 # undef DIM_4d 326 327 !!====================================================================== 681 328 END MODULE lbclnk 682 329
Note: See TracChangeset
for help on using the changeset viewer.
