- Timestamp:
- 2017-06-19T11:25:07+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r8170 r8186 7 7 !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module 8 8 !! 3.2 ! 2009-03 (R. Benshila) External north fold treatment 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 10 10 !! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case 11 11 !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi 12 12 !! 4.0 ! 2017-03 (G. Madec) automatique allocation of array size (use with any 3rd dim size) 13 13 !! - ! 2017-04 (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather) 14 !! - ! 2017-05 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 14 15 !!---------------------------------------------------------------------- 15 16 #if defined key_mpp_mpi … … 20 21 !!---------------------------------------------------------------------- 21 22 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 22 !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp23 23 !! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 24 24 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 25 25 !!---------------------------------------------------------------------- 26 USE par_oce ! ocean dynamics and tracers 26 27 USE lib_mpp ! distributed memory computing library 27 28 USE lbcnfd ! north fold 29 30 INTERFACE lbc_lnk 31 MODULE PROCEDURE mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 32 END INTERFACE 33 INTERFACE lbc_lnk_ptr 34 MODULE PROCEDURE mpp_lnk_2d_ptr , mpp_lnk_3d_ptr , mpp_lnk_4d_ptr 35 END INTERFACE 28 36 INTERFACE lbc_lnk_multi 29 MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 30 END INTERFACE 31 ! 32 INTERFACE lbc_lnk 33 MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 34 END INTERFACE 35 ! 36 INTERFACE lbc_sum 37 MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 37 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 38 38 END INTERFACE 39 39 ! … … 52 52 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 53 53 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 54 PUBLIC lbc_sum ! sum across processors55 54 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions 56 55 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions … … 62 61 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 63 62 !!---------------------------------------------------------------------- 63 CONTAINS 64 64 65 #else 65 66 !!---------------------------------------------------------------------- … … 69 70 !! on first and last row and column of the global domain 70 71 !!---------------------------------------------------------------------- 71 !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d72 72 !! lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 73 73 !! lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh … … 86 86 87 87 INTERFACE lbc_lnk 88 MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d 89 END INTERFACE 90 ! 91 INTERFACE lbc_sum 92 MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 88 MODULE PROCEDURE lbc_lnk_2d , lbc_lnk_3d , lbc_lnk_4d 89 END INTERFACE 90 INTERFACE lbc_lnk_ptr 91 MODULE PROCEDURE lbc_lnk_2d_ptr , lbc_lnk_3d_ptr , lbc_lnk_4d_ptr 92 END INTERFACE 93 INTERFACE lbc_lnk_multi 94 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 93 95 END INTERFACE 94 96 ! … … 97 99 END INTERFACE 98 100 ! 99 INTERFACE lbc_lnk_multi100 MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple101 END INTERFACE102 !103 101 INTERFACE lbc_bdy_lnk 104 102 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 109 107 END INTERFACE 110 108 111 TYPE arrayptr112 REAL , DIMENSION (:,:), POINTER :: pt2d113 END TYPE arrayptr114 !115 PUBLIC arrayptr116 117 109 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 118 PUBLIC lbc_sum ! ocean/ice lateral boundary conditions (sum of the overlap region)119 110 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions 120 111 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions … … 130 121 131 122 # if defined key_c1d 132 !! ----------------------------------------------------------------------123 !!====================================================================== 133 124 !! 'key_c1d' 1D configuration 134 !! ----------------------------------------------------------------------125 !!====================================================================== 135 126 !! central point value replicated over the 8 surrounding points 136 127 !!---------------------------------------------------------------------- … … 185 176 186 177 #else 187 !! ----------------------------------------------------------------------178 !!====================================================================== 188 179 !! Default option 3D shared memory computing 189 !! ----------------------------------------------------------------------180 !!====================================================================== 190 181 !! routines setting land point, or east-west cyclic, 191 182 !! or north-south cyclic, or north fold values … … 193 184 !!---------------------------------------------------------------------- 194 185 195 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 196 !!--------------------------------------------------------------------- 197 !! *** ROUTINE lbc_lnk_3d *** 198 !! 199 !! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case) 200 !! 201 !! ** Method : psign = -1 : change the sign across the north fold 202 !! = 1 : no change of the sign across the north fold 203 !! = 0 : no change of the sign across the north fold and 204 !! strict positivity preserved: use inner row/column 205 !! for closed boundaries. 206 !!---------------------------------------------------------------------- 207 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 208 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 209 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 210 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 211 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 212 ! 213 REAL(wp) :: zland 214 !!---------------------------------------------------------------------- 215 ! 216 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 217 ELSE ; zland = 0._wp 218 ENDIF 219 ! 220 IF( PRESENT( cd_mpp ) ) THEN 221 ! only fill the overlap area and extra allows 222 ! this is in mpp case. In this module, just do nothing 223 ELSE 224 ! ! East-West boundaries 225 ! ! ====================== 226 SELECT CASE ( nperio ) 227 ! 228 CASE ( 1 , 4 , 6 ) !** cyclic east-west 229 pt3d( 1 ,:,:) = pt3d(jpim1,:,:) ! all points 230 pt3d(jpi,:,:) = pt3d( 2 ,:,:) 231 ! 232 CASE DEFAULT !** East closed -- West closed 233 SELECT CASE ( cd_type ) 234 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 235 pt3d( 1 ,:,:) = zland 236 pt3d(jpi,:,:) = zland 237 CASE ( 'F' ) ! F-point 238 pt3d(jpi,:,:) = zland 239 END SELECT 240 ! 241 END SELECT 242 ! ! North-South boundaries 243 ! ! ====================== 244 SELECT CASE ( nperio ) 245 ! 246 CASE ( 2 ) !** South symmetric -- North closed 247 SELECT CASE ( cd_type ) 248 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 249 pt3d(:, 1 ,:) = pt3d(:,3,:) 250 pt3d(:,jpj,:) = zland 251 CASE ( 'V' , 'F' ) ! V-, F-points 252 pt3d(:, 1 ,:) = psgn * pt3d(:,2,:) 253 pt3d(:,jpj,:) = zland 254 END SELECT 255 ! 256 CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed 257 SELECT CASE ( cd_type ) ! South : closed 258 CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point 259 pt3d(:, 1 ,:) = zland 260 END SELECT 261 ! ! North fold 262 CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn ) 263 ! 264 CASE DEFAULT !** North closed -- South closed 265 SELECT CASE ( cd_type ) 266 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 267 pt3d(:, 1 ,:) = zland 268 pt3d(:,jpj,:) = zland 269 CASE ( 'F' ) ! F-point 270 pt3d(:,jpj,:) = zland 271 END SELECT 272 ! 273 END SELECT 274 ! 275 ENDIF 276 ! 277 END SUBROUTINE lbc_lnk_3d 278 279 280 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 281 !!--------------------------------------------------------------------- 282 !! *** ROUTINE lbc_lnk_2d *** 283 !! 284 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case) 285 !! 286 !! ** Method : psign = -1 : change the sign across the north fold 287 !! = 1 : no change of the sign across the north fold 288 !! = 0 : no change of the sign across the north fold and 289 !! strict positivity preserved: use inner row/column 290 !! for closed boundaries. 291 !!---------------------------------------------------------------------- 292 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 293 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 294 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 295 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 296 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 297 !! 298 REAL(wp) :: zland 299 !!---------------------------------------------------------------------- 300 301 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 302 ELSE ; zland = 0._wp 303 ENDIF 304 305 IF (PRESENT(cd_mpp)) THEN 306 ! only fill the overlap area and extra allows 307 ! this is in mpp case. In this module, just do nothing 308 ELSE 309 ! ! East-West boundaries 310 ! ! ==================== 311 SELECT CASE ( nperio ) 312 ! 313 CASE ( 1 , 4 , 6 ) !** cyclic east-west 314 pt2d( 1 ,:) = pt2d(jpim1,:) ! all points 315 pt2d(jpi,:) = pt2d( 2 ,:) 316 ! 317 CASE DEFAULT !** East closed -- West closed 318 SELECT CASE ( cd_type ) 319 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 320 pt2d( 1 ,:) = zland 321 pt2d(jpi,:) = zland 322 CASE ( 'F' ) ! F-point 323 pt2d(jpi,:) = zland 324 END SELECT 325 ! 326 END SELECT 327 ! ! North-South boundaries 328 ! ! ====================== 329 SELECT CASE ( nperio ) 330 ! 331 CASE ( 2 ) !** South symmetric -- North closed 332 SELECT CASE ( cd_type ) 333 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 334 pt2d(:, 1 ) = pt2d(:,3) 335 pt2d(:,jpj) = zland 336 CASE ( 'V' , 'F' ) ! V-, F-points 337 pt2d(:, 1 ) = psgn * pt2d(:,2) 338 pt2d(:,jpj) = zland 339 END SELECT 340 ! 341 CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed 342 SELECT CASE ( cd_type ) ! South : closed 343 CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point 344 pt2d(:, 1 ) = zland 345 END SELECT 346 ! ! North fold 347 CALL lbc_nfd( pt2d(:,:), cd_type, psgn ) 348 ! 349 CASE DEFAULT !** North closed -- South closed 350 SELECT CASE ( cd_type ) 351 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 352 pt2d(:, 1 ) = zland 353 pt2d(:,jpj) = zland 354 CASE ( 'F' ) ! F-point 355 pt2d(:,jpj) = zland 356 END SELECT 357 ! 358 END SELECT 359 ! 360 ENDIF 361 ! 362 END SUBROUTINE lbc_lnk_2d 186 !!---------------------------------------------------------------------- 187 !! *** routine lbc_lnk_(2,3,4)d *** 188 !! 189 !! * Argument : dummy argument use in lbc_lnk_... routines 190 !! ptab : array or pointer of arrays on which the boundary condition is applied 191 !! cd_nat : nature of array grid-points 192 !! psgn : sign used across the north fold boundary 193 !! kfld : optional, number of pt3d arrays 194 !! cd_mpp : optional, fill the overlap area only 195 !! pval : optional, background value (used at closed boundaries) 196 !!---------------------------------------------------------------------- 197 ! 198 ! !== 2D array and array of 2D pointer ==! 199 ! 200 # define DIM_2d 201 # define ROUTINE_LNK lbc_lnk_2d 202 # include "lbc_lnk_generic.h90" 203 # undef ROUTINE_LNK 204 # define MULTI 205 # define ROUTINE_LNK lbc_lnk_2d_ptr 206 # include "lbc_lnk_generic.h90" 207 # undef ROUTINE_LNK 208 # undef MULTI 209 # undef DIM_2d 210 ! 211 ! !== 3D array and array of 3D pointer ==! 212 ! 213 # define DIM_3d 214 # define ROUTINE_LNK lbc_lnk_3d 215 # include "lbc_lnk_generic.h90" 216 # undef ROUTINE_LNK 217 # define MULTI 218 # define ROUTINE_LNK lbc_lnk_3d_ptr 219 # include "lbc_lnk_generic.h90" 220 # undef ROUTINE_LNK 221 # undef MULTI 222 # undef DIM_3d 223 ! 224 ! !== 4D array and array of 4D pointer ==! 225 ! 226 # define DIM_4d 227 # define ROUTINE_LNK lbc_lnk_4d 228 # include "lbc_lnk_generic.h90" 229 # undef ROUTINE_LNK 230 # define MULTI 231 # define ROUTINE_LNK lbc_lnk_4d_ptr 232 # include "lbc_lnk_generic.h90" 233 # undef ROUTINE_LNK 234 # undef MULTI 235 # undef DIM_4d 363 236 364 237 #endif 365 238 366 !!---------------------------------------------------------------------- 367 !! identical routines in both C1D and shared memory computing cases 368 !!---------------------------------------------------------------------- 369 370 SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 371 !!--------------------------------------------------------------------- 372 !! *** ROUTINE lbc_lnk_3d_gather *** 373 !! 374 !! ** Purpose : set lateral boundary conditions on two 3D arrays (C1D case) 375 !! 376 !! ** Method : call lbc_lnk_3d on pt3d1 and pt3d2 377 !!---------------------------------------------------------------------- 378 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied 379 CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! nature of pt3d1 & pt3d2 grid-points 380 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 381 !!---------------------------------------------------------------------- 382 ! 383 CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 384 CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 385 ! 386 END SUBROUTINE lbc_lnk_3d_gather 387 388 389 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld ) 390 !!--------------------------------------------------------------------- 391 TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields 392 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! nature of ptab_array grid-points 393 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! sign used across the north fold boundary 394 INTEGER , INTENT(in ) :: kfld ! number of 2D fields 395 ! 396 INTEGER :: jf !dummy loop index 397 !!--------------------------------------------------------------------- 398 ! 399 DO jf = 1, kfld 400 CALL lbc_lnk_2d( pt2d_array(jf)%pt2d, type_array(jf), psgn_array(jf) ) 401 END DO 402 ! 403 END SUBROUTINE lbc_lnk_2d_multiple 404 405 406 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC, & 407 & pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF, & 408 & pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, & 409 & cd_mpp, pval ) 410 !!--------------------------------------------------------------------- 411 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA ! 2D arrays on which the lbc is applied 412 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 413 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 414 CHARACTER(len=1) , INTENT(in ) :: cd_typeA ! nature of pt2D. array grid-points 415 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 416 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 417 REAL(wp) , INTENT(in ) :: psgnA ! sign used across the north fold 418 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 419 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 420 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 421 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 422 !! 423 !!--------------------------------------------------------------------- 424 ! 425 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) ! The first array 426 ! 427 IF( PRESENT (psgnB) ) CALL lbc_lnk( pt2dB, cd_typeB, psgnB ) ! Look if more arrays to process 428 IF( PRESENT (psgnC) ) CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 429 IF( PRESENT (psgnD) ) CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 430 IF( PRESENT (psgnE) ) CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 431 IF( PRESENT (psgnF) ) CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 432 IF( PRESENT (psgnG) ) CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 433 IF( PRESENT (psgnH) ) CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 434 IF( PRESENT (psgnI) ) CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 435 ! 436 END SUBROUTINE lbc_lnk_2d_9 437 438 239 !!====================================================================== 240 !! identical routines in both C1D and shared memory computing 241 !!====================================================================== 242 243 !!---------------------------------------------------------------------- 244 !! *** routine lbc_bdy_lnk_(2,3)d *** 245 !! 246 !! wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 247 !! to maintain the same interface with regards to the mpp case 248 !!---------------------------------------------------------------------- 249 439 250 SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 440 !!---------------------------------------------------------------------441 !! *** ROUTINE lbc_bdy_lnk ***442 !!443 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used444 !! to maintain the same interface with regards to the mpp case445 251 !!---------------------------------------------------------------------- 446 252 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied … … 449 255 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 450 256 !!---------------------------------------------------------------------- 451 !452 257 CALL lbc_lnk_3d( pt3d, cd_type, psgn) 453 !454 258 END SUBROUTINE lbc_bdy_lnk_3d 455 259 456 260 457 261 SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 458 !!---------------------------------------------------------------------459 !! *** ROUTINE lbc_bdy_lnk ***460 !!461 !! ** Purpose : wrapper rountine to 'lbc_lnk_2d'. This wrapper is used462 !! to maintain the same interface with regards to the mpp case463 262 !!---------------------------------------------------------------------- 464 263 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied … … 467 266 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 468 267 !!---------------------------------------------------------------------- 469 !470 268 CALL lbc_lnk_2d( pt2d, cd_type, psgn) 471 !472 269 END SUBROUTINE lbc_bdy_lnk_2d 473 270 474 271 272 !!gm This routine should be remove with an optional halos size added in orgument of generic routines 273 475 274 SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, ki, kj ) 476 !!---------------------------------------------------------------------477 !! *** ROUTINE lbc_lnk_2d ***478 !!479 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case)480 !! special dummy routine to allow for use of halo indexing in mpp case481 275 !!---------------------------------------------------------------------- 482 276 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied … … 485 279 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp) 486 280 !!---------------------------------------------------------------------- 487 !488 281 CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 489 !490 282 END SUBROUTINE lbc_lnk_2d_e 491 492 493 SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 494 !!--------------------------------------------------------------------- 495 !! *** ROUTINE lbc_lnk_sum_2d *** 496 !! 497 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case) 498 !! 499 !! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean 500 !! coupling if conservation option activated. As no ice shelf are present along 501 !! this line, nothing is done along the north fold. 502 !!---------------------------------------------------------------------- 503 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 504 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 505 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 506 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 507 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 508 !! 509 REAL(wp) :: zland 510 !!---------------------------------------------------------------------- 511 ! 512 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 513 ELSE ; zland = 0._wp 514 ENDIF 515 ! 516 IF (PRESENT(cd_mpp)) THEN 517 ! only fill the overlap area and extra allows 518 ! this is in mpp case. In this module, just do nothing 519 ELSE 520 ! ! East-West boundaries 521 ! ! ==================== 522 SELECT CASE ( nperio ) 523 ! 524 CASE ( 1 , 4 , 6 ) !** cyclic east-west 525 pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:) 526 pt2d( 2 ,:) = pt2d( 2 ,:) + pt2d(jpi,:) 527 pt2d( 1 ,:) = 0.0_wp ! all points 528 pt2d(jpi,:) = 0.0_wp 529 ! 530 CASE DEFAULT !** East closed -- West closed 531 SELECT CASE ( cd_type ) 532 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 533 pt2d( 1 ,:) = zland 534 pt2d(jpi,:) = zland 535 CASE ( 'F' ) ! F-point 536 pt2d(jpi,:) = zland 537 END SELECT 538 ! 539 END SELECT 540 ! ! North-South boundaries 541 ! ! ====================== 542 ! Nothing to do for the north fold, there is no ice shelf along this line. 543 ! 544 END IF 545 ! 546 END SUBROUTINE 547 548 549 SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 550 !!--------------------------------------------------------------------- 551 !! *** ROUTINE lbc_lnk_sum_3d *** 552 !! 553 !! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case) 554 !! 555 !! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean 556 !! coupling if conservation option activated. As no ice shelf are present along 557 !! this line, nothing is done along the north fold. 558 !!---------------------------------------------------------------------- 559 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 560 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 561 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 562 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 563 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 564 ! 565 REAL(wp) :: zland 566 !!---------------------------------------------------------------------- 567 ! 568 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 569 ELSE ; zland = 0._wp 570 ENDIF 571 ! 572 IF( PRESENT( cd_mpp ) ) THEN 573 ! only fill the overlap area and extra allows 574 ! this is in mpp case. In this module, just do nothing 575 ELSE 576 ! ! East-West boundaries 577 ! ! ====================== 578 SELECT CASE ( nperio ) 579 ! 580 CASE ( 1 , 4 , 6 ) !** cyclic east-west 581 pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 582 pt3d( 2 ,:,:) = pt3d( 2 ,:,:) + pt3d(jpi,:,:) 583 pt3d( 1 ,:,:) = 0._wp 584 pt3d(jpi,:,:) = 0._wp 585 ! 586 CASE DEFAULT !** East closed -- West closed 587 SELECT CASE ( cd_type ) 588 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 589 pt3d( 1 ,:,:) = zland 590 pt3d(jpi,:,:) = zland 591 CASE ( 'F' ) ! F-point 592 pt3d(jpi,:,:) = zland 593 END SELECT 594 ! 595 END SELECT 596 ! ! North-South boundaries 597 ! ! ====================== 598 ! Nothing to do for the north fold, there is no ice shelf along this line. 599 ! 600 END IF 601 ! 602 END SUBROUTINE 283 !!gm end 603 284 604 285 #endif 605 286 606 287 !!====================================================================== 288 !! identical routines in both distributed and shared memory computing 289 !!====================================================================== 290 291 !!---------------------------------------------------------------------- 292 !! *** load_ptr_(2,3,4)d *** 293 !! 294 !! * Dummy Argument : 295 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 296 !! cd_nat ! nature of pt2d array grid-points 297 !! psgn ! sign used across the north fold boundary 298 !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers 299 !! cdna_ptr ! nature of ptab array grid-points 300 !! psgn_ptr ! sign used across the north fold boundary 301 !! kfld ! number of elements that has been attributed 302 !!---------------------------------------------------------------------- 303 304 !!---------------------------------------------------------------------- 305 !! *** lbc_lnk_(2,3,4)d_multi *** 306 !! *** load_ptr_(2,3,4)d *** 307 !! 308 !! * Argument : dummy argument use in lbc_lnk_multi_... routines 309 !! 310 !!---------------------------------------------------------------------- 311 312 # define DIM_2d 313 # define ROUTINE_MULTI lbc_lnk_2d_multi 314 # define ROUTINE_LOAD load_ptr_2d 315 # include "lbc_lnk_multi_generic.h90" 316 # undef ROUTINE_MULTI 317 # undef ROUTINE_LOAD 318 # undef DIM_2d 319 320 321 # define DIM_3d 322 # define ROUTINE_MULTI lbc_lnk_3d_multi 323 # define ROUTINE_LOAD load_ptr_3d 324 # include "lbc_lnk_multi_generic.h90" 325 # undef ROUTINE_MULTI 326 # undef ROUTINE_LOAD 327 # undef DIM_3d 328 329 330 # define DIM_4d 331 # define ROUTINE_MULTI lbc_lnk_4d_multi 332 # define ROUTINE_LOAD load_ptr_4d 333 # include "lbc_lnk_multi_generic.h90" 334 # undef ROUTINE_MULTI 335 # undef ROUTINE_LOAD 336 # undef DIM_4d 337 338 !!====================================================================== 607 339 END MODULE lbclnk 608 340
Note: See TracChangeset
for help on using the changeset viewer.
