Changeset 7897 for branches/2017/dev_r7832_HPC08_lbclnk_3rd_dim/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
- Timestamp:
- 2017-04-11T15:10:20+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r7832_HPC08_lbclnk_3rd_dim/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r7753 r7897 8 8 !! 8.0 ! 1998 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI 9 9 !! ! 1998 (J.M. Molines) Open boundary conditions 10 !! NEMO 1.0 ! 2003 (J. -M. Molines, G. Madec) F90, free form10 !! NEMO 1.0 ! 2003 (J.M. Molines, G. Madec) F90, free form 11 11 !! ! 2003 (J.M. Molines) add mpp_ini_north(_3d,_2d) 12 12 !! - ! 2004 (R. Bourdalle Badie) isend option in mpi … … 24 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple' 26 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max 27 !! 4.0 ! 2017 (G. Madec) automatique allocation of array argument (use any 3rd dimension) 27 28 !!---------------------------------------------------------------------- 28 29 … … 45 46 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 46 47 !! mpprecv : 47 !! mppsend : SUBROUTINE mpp_ini_znl48 !! mppsend : 48 49 !! mppscatter : 49 50 !! mppgather : … … 85 86 86 87 TYPE arrayptr 87 REAL , DIMENSION (:,:), POINTER ::pt2d88 REAL(wp), DIMENSION (:,:), POINTER :: pt2d 88 89 END TYPE arrayptr 90 ! 89 91 PUBLIC arrayptr 90 92 … … 101 103 INTERFACE mpp_sum 102 104 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 103 105 & mppsum_realdd, mppsum_a_realdd 104 106 END INTERFACE 105 107 INTERFACE mpp_lbc_north … … 112 114 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 113 115 END INTERFACE 114 115 116 INTERFACE mpp_max_multiple 116 117 MODULE PROCEDURE mppmax_real_multiple … … 138 139 ! variables used in case of sea-ice 139 140 INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in limthd) 140 INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology)141 INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology)142 INTEGER :: ndim_rank_ice ! number of 'ice' processors143 INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm141 INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology) 142 INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology) 143 INTEGER :: ndim_rank_ice ! number of 'ice' processors 144 INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm 144 145 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_ice ! dimension ndim_rank_ice 145 146 146 147 ! variables used for zonal integration 147 148 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average 148 LOGICAL, PUBLIC :: l_znl_root ! True on the 'left'most processor on the same row149 INTEGER :: ngrp_znl !group ID for the znl processors150 INTEGER :: ndim_rank_znl !number of processors on the same zonal average149 LOGICAL, PUBLIC :: l_znl_root ! True on the 'left'most processor on the same row 150 INTEGER :: ngrp_znl ! group ID for the znl processors 151 INTEGER :: ndim_rank_znl ! number of processors on the same zonal average 151 152 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 152 153 153 154 ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) 154 INTEGER, PUBLIC :: ngrp_world ! group ID for the world processors155 INTEGER, PUBLIC :: ngrp_opa ! group ID for the opa processors156 INTEGER, PUBLIC :: ngrp_north ! group ID for the northern processors (to be fold)157 INTEGER, PUBLIC :: ncomm_north ! communicator made by the processors belonging to ngrp_north158 INTEGER, PUBLIC :: ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !)159 INTEGER, PUBLIC :: njmppmax ! value of njmpp for the processors of the northern line160 INTEGER, PUBLIC :: north_root ! number (in the comm_opa) of proc 0 in the northern comm161 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: nrank_north !dimension ndim_rank_north155 INTEGER, PUBLIC :: ngrp_world !: group ID for the world processors 156 INTEGER, PUBLIC :: ngrp_opa !: group ID for the opa processors 157 INTEGER, PUBLIC :: ngrp_north !: group ID for the northern processors (to be fold) 158 INTEGER, PUBLIC :: ncomm_north !: communicator made by the processors belonging to ngrp_north 159 INTEGER, PUBLIC :: ndim_rank_north !: number of 'sea' processor in the northern line (can be /= jpni !) 160 INTEGER, PUBLIC :: njmppmax !: value of njmpp for the processors of the northern line 161 INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm 162 INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north 162 163 163 164 ! Type of send : standard, buffered, immediate 164 CHARACTER(len=1), PUBLIC :: cn_mpi_send !type od mpi send/recieve (S=standard, B=bsend, I=isend)165 LOGICAL , PUBLIC :: l_isend = .FALSE. !isend use indicator (T if cn_mpi_send='I')166 INTEGER , PUBLIC :: nn_buffer !size of the buffer in case of mpi_bsend167 168 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon! buffer in case of bsend169 170 LOGICAL, PUBLIC :: ln_nnogather !namelist control of northfold comms171 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !internal control of northfold comms172 INTEGER, PUBLIC :: ityp 165 CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 166 LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I') 167 INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend 168 169 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend 170 171 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 172 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 173 173 174 !!---------------------------------------------------------------------- 174 !! NEMO/OPA 3.3 , NEMO Consortium (2010)175 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 175 176 !! $Id$ 176 177 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 178 179 CONTAINS 179 180 180 181 FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 181 FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 182 182 !!---------------------------------------------------------------------- 183 183 !! *** routine mynode *** … … 204 204 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 205 205 ! 206 207 206 REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables 208 207 READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 209 208 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 210 209 ! 211 210 REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables 212 211 READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 213 212 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 214 213 ! 215 214 ! ! control print 216 215 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 217 216 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 218 217 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 219 218 ! 220 219 #if defined key_agrif 221 220 IF( .NOT. Agrif_Root() ) THEN … … 225 224 ENDIF 226 225 #endif 227 228 IF(jpnij < 1)THEN 229 ! If jpnij is not specified in namelist then we calculate it - this 230 ! means there will be no land cutting out. 231 jpnij = jpni * jpnj 232 END IF 233 234 IF( (jpni < 1) .OR. (jpnj < 1) )THEN 226 ! 227 IF( jpnij < 1 ) THEN ! If jpnij is not specified in namelist then we calculate it 228 jpnij = jpni * jpnj ! this means there will be no land cutting out. 229 ENDIF 230 231 IF( jpni < 1 .OR. jpnj < 1 ) THEN 235 232 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1 236 233 ELSE … … 238 235 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 239 236 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1 240 END 237 ENDIF 241 238 242 239 WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 … … 268 265 kstop = kstop + 1 269 266 END SELECT 270 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 267 ! 268 ELSE IF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 271 269 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 272 270 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 … … 309 307 310 308 #if defined key_agrif 311 IF (Agrif_Root()) THEN309 IF( Agrif_Root() ) THEN 312 310 CALL Agrif_MPI_Init(mpi_comm_opa) 313 311 ELSE … … 335 333 !! 336 334 !! ** Purpose : Message passing manadgement 335 !! 336 !! ** Method : Use mppsend and mpprecv function for passing mask 337 !! between processors following neighboring subdomains. 338 !! domain parameters 339 !! nlci : first dimension of the local subdomain 340 !! nlcj : second dimension of the local subdomain 341 !! nbondi : mark for "east-west local boundary" 342 !! nbondj : mark for "north-south local boundary" 343 !! noea : number for local neighboring processors 344 !! nowe : number for local neighboring processors 345 !! noso : number for local neighboring processors 346 !! nono : number for local neighboring processors 347 !! 348 !! ** Action : ptab with update value at its periphery 349 !!---------------------------------------------------------------------- 350 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 351 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 352 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 353 CHARACTER(len=3), OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 354 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 355 ! 356 INTEGER :: ji, jj, jk, jl ! dummy loop indices 357 INTEGER :: ipk ! 3rd dimension of the input array 358 INTEGER :: imigr, iihom, ijhom ! temporary integers 359 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 360 REAL(wp) :: zland 361 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 362 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 363 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 364 !!---------------------------------------------------------------------- 365 ! 366 ipk = SIZE( ptab, 3 ) 367 ! 368 ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2), & 369 & zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2) ) 370 371 ! 372 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 373 ELSE ; zland = 0._wp ! zero by default 374 ENDIF 375 376 ! 1. standard boundary treatment 377 ! ------------------------------ 378 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 379 ! 380 ! WARNING ptab is defined only between nld and nle 381 DO jk = 1, ipk 382 DO jj = nlcj+1, jpj ! added line(s) (inner only) 383 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 384 ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) 385 ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) 386 END DO 387 DO ji = nlci+1, jpi ! added column(s) (full) 388 ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk) 389 ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk) 390 ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk) 391 END DO 392 END DO 393 ! 394 ELSE ! standard close or cyclic treatment 395 ! 396 ! ! East-West boundaries 397 ! !* Cyclic 398 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 399 ptab( 1 ,:,:) = ptab(jpim1,:,:) 400 ptab(jpi,:,:) = ptab( 2 ,:,:) 401 ELSE !* closed 402 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 403 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 404 ENDIF 405 ! ! North-South boundaries 406 ! !* cyclic (only with no mpp j-split) 407 IF( nbondj == 2 .AND. jperio == 7 ) THEN 408 ptab(:,1 , :) = ptab(:, jpjm1,:) 409 ptab(:,jpj,:) = ptab(:, 2,:) 410 ELSE !* closed 411 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 412 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 413 ENDIF 414 ! 415 ENDIF 416 417 ! 2. East and west directions exchange 418 ! ------------------------------------ 419 ! we play with the neigbours AND the row number because of the periodicity 420 ! 421 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 422 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 423 iihom = nlci-nreci 424 DO jl = 1, jpreci 425 zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 426 zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 427 END DO 428 END SELECT 429 ! 430 ! ! Migrations 431 imigr = jpreci * jpj * ipk 432 ! 433 SELECT CASE ( nbondi ) 434 CASE ( -1 ) 435 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 436 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 437 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 438 CASE ( 0 ) 439 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 440 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 441 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 442 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 443 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 444 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 445 CASE ( 1 ) 446 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 447 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 448 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 449 END SELECT 450 ! 451 ! ! Write Dirichlet lateral conditions 452 iihom = nlci-jpreci 453 ! 454 SELECT CASE ( nbondi ) 455 CASE ( -1 ) 456 DO jl = 1, jpreci 457 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 458 END DO 459 CASE ( 0 ) 460 DO jl = 1, jpreci 461 ptab(jl ,:,:) = zt3we(:,jl,:,2) 462 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 463 END DO 464 CASE ( 1 ) 465 DO jl = 1, jpreci 466 ptab(jl ,:,:) = zt3we(:,jl,:,2) 467 END DO 468 END SELECT 469 470 ! 3. North and south directions 471 ! ----------------------------- 472 ! always closed : we play only with the neigbours 473 ! 474 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 475 ijhom = nlcj-nrecj 476 DO jl = 1, jprecj 477 zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 478 zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 479 END DO 480 ENDIF 481 ! 482 ! ! Migrations 483 imigr = jprecj * jpi * ipk 484 ! 485 SELECT CASE ( nbondj ) 486 CASE ( -1 ) 487 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 488 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 489 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 490 CASE ( 0 ) 491 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 492 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 493 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 494 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 495 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 496 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 497 CASE ( 1 ) 498 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 499 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 500 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 501 END SELECT 502 ! 503 ! ! Write Dirichlet lateral conditions 504 ijhom = nlcj-jprecj 505 ! 506 SELECT CASE ( nbondj ) 507 CASE ( -1 ) 508 DO jl = 1, jprecj 509 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 510 END DO 511 CASE ( 0 ) 512 DO jl = 1, jprecj 513 ptab(:,jl ,:) = zt3sn(:,jl,:,2) 514 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 515 END DO 516 CASE ( 1 ) 517 DO jl = 1, jprecj 518 ptab(:,jl,:) = zt3sn(:,jl,:,2) 519 END DO 520 END SELECT 521 522 ! 4. north fold treatment 523 ! ----------------------- 524 ! 525 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 526 ! 527 SELECT CASE ( jpni ) 528 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 529 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 530 END SELECT 531 ! 532 ENDIF 533 ! 534 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 535 ! 536 END SUBROUTINE mpp_lnk_3d 537 538 539 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp, pval ) 540 !!---------------------------------------------------------------------- 541 !! *** routine mpp_lnk_2d_multiple *** 542 !! 543 !! ** Purpose : Message passing management for multiple 2d arrays 337 544 !! 338 545 !! ** Method : Use mppsend and mpprecv function for passing mask … … 347 554 !! noso : number for local neighboring processors 348 555 !! nono : number for local neighboring processors 349 !! 350 !! ** Action : ptab with update value at its periphery 351 !! 352 !!---------------------------------------------------------------------- 353 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 354 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 355 ! ! = T , U , V , F , W points 356 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 357 ! ! = 1. , the sign is kept 358 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 359 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 360 ! 361 INTEGER :: ji, jj, jk, jl ! dummy loop indices 556 !!---------------------------------------------------------------------- 557 TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields 558 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! nature of pt2d_array grid-points 559 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! sign used across the north fold boundary 560 INTEGER , INTENT(in ) :: kfld ! number of pt2d arrays 561 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 562 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 563 ! 564 INTEGER :: ji, jj, jl, jf ! dummy loop indices 362 565 INTEGER :: imigr, iihom, ijhom ! temporary integers 363 566 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 364 567 REAL(wp) :: zland 365 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 366 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 367 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 368 !!---------------------------------------------------------------------- 369 370 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 371 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 372 568 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 569 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 570 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 571 !!---------------------------------------------------------------------- 572 ! 573 ALLOCATE( zt2ns(jpi,jprecj,2*kfld), zt2sn(jpi,jprecj,2*kfld), & 574 & zt2ew(jpj,jpreci,2*kfld), zt2we(jpj,jpreci,2*kfld) ) 373 575 ! 374 576 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value … … 378 580 ! 1. standard boundary treatment 379 581 ! ------------------------------ 380 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 381 ! 382 ! WARNING ptab is defined only between nld and nle 383 DO jk = 1, jpk 582 ! 583 !First Array 584 DO jf = 1 , kfld 585 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 586 ! 587 ! WARNING pt2d is defined only between nld and nle 384 588 DO jj = nlcj+1, jpj ! added line(s) (inner only) 385 pt ab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk)386 pt ab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk)387 pt ab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk)589 pt2d_array(jf)%pt2d(nldi :nlei , jj) = pt2d_array(jf)%pt2d(nldi:nlei, nlej) 590 pt2d_array(jf)%pt2d(1 :nldi-1, jj) = pt2d_array(jf)%pt2d(nldi , nlej) 591 pt2d_array(jf)%pt2d(nlei+1:nlci , jj) = pt2d_array(jf)%pt2d( nlei, nlej) 388 592 END DO 389 593 DO ji = nlci+1, jpi ! added column(s) (full) 390 pt ab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk)391 pt ab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk)392 pt ab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk)594 pt2d_array(jf)%pt2d(ji, nldj :nlej ) = pt2d_array(jf)%pt2d(nlei, nldj:nlej) 595 pt2d_array(jf)%pt2d(ji, 1 :nldj-1) = pt2d_array(jf)%pt2d(nlei, nldj ) 596 pt2d_array(jf)%pt2d(ji, nlej+1:jpj ) = pt2d_array(jf)%pt2d(nlei, nlej) 393 597 END DO 394 END DO 395 ! 396 ELSE ! standard close or cyclic treatment 397 ! 398 ! ! East-West boundaries 399 ! !* Cyclic east-west 400 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 401 ptab( 1 ,:,:) = ptab(jpim1,:,:) 402 ptab(jpi,:,:) = ptab( 2 ,:,:) 403 ELSE !* closed 404 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 405 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 598 ! 599 ELSE ! standard close or cyclic treatment 600 ! 601 ! ! East-West boundaries 602 IF( nbondi == 2 .AND. & !* Cyclic 603 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 604 pt2d_array(jf)%pt2d( 1 , : ) = pt2d_array(jf)%pt2d( jpim1, : ) ! west 605 pt2d_array(jf)%pt2d( jpi , : ) = pt2d_array(jf)%pt2d( 2 , : ) ! east 606 ELSE !* Closed 607 IF( .NOT. type_array(jf) == 'F' ) pt2d_array(jf)%pt2d( 1 : jpreci,:) = zland ! south except F-point 608 pt2d_array(jf)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north 609 ENDIF 610 ! ! North-South boundaries 611 ! !* Cyclic 612 IF( nbondj == 2 .AND. jperio == 7 ) THEN 613 pt2d_array(jf)%pt2d(:, 1 ) = pt2d_array(jf)%pt2d(:, jpjm1 ) 614 pt2d_array(jf)%pt2d(:, jpj ) = pt2d_array(jf)%pt2d(:, 2 ) 615 ELSE !* Closed 616 IF( .NOT. type_array(jf) == 'F' ) pt2d_array(jf)%pt2d(:, 1:jprecj ) = zland ! south except F-point 617 pt2d_array(jf)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north 618 ENDIF 406 619 ENDIF 407 ! North-south cyclic 408 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south only with no mpp split in latitude 409 ptab(:,1 , :) = ptab(:, jpjm1,:) 410 ptab(:,jpj,:) = ptab(:, 2,:) 411 ELSE ! ! North-South boundaries (closed) 412 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 413 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 414 ENDIF 415 ! 416 ENDIF 620 END DO 417 621 418 622 ! 2. East and west directions exchange … … 420 624 ! we play with the neigbours AND the row number because of the periodicity 421 625 ! 422 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 423 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 424 iihom = nlci-nreci 425 DO jl = 1, jpreci 426 zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 427 zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 428 END DO 429 END SELECT 626 DO jf = 1 , kfld 627 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 628 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 629 iihom = nlci-nreci 630 DO jl = 1, jpreci 631 zt2ew( : , jl , jf ) = pt2d_array(jf)%pt2d( jpreci+jl , : ) 632 zt2we( : , jl , jf ) = pt2d_array(jf)%pt2d( iihom +jl , : ) 633 END DO 634 END SELECT 635 END DO 430 636 ! 431 637 ! ! Migrations 432 imigr = jpreci * jpj * jpk638 imigr = jpreci * jpj 433 639 ! 434 640 SELECT CASE ( nbondi ) 435 641 CASE ( -1 ) 436 CALL mppsend( 2, zt 3we(1,1,1,1),imigr, noea, ml_req1 )437 CALL mpprecv( 1, zt 3ew(1,1,1,2),imigr, noea )438 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat,ml_err)439 CASE ( 0 ) 440 CALL mppsend( 1, zt 3ew(1,1,1,1),imigr, nowe, ml_req1 )441 CALL mppsend( 2, zt 3we(1,1,1,1),imigr, noea, ml_req2 )442 CALL mpprecv( 1, zt 3ew(1,1,1,2),imigr, noea )443 CALL mpprecv( 2, zt 3we(1,1,1,2),imigr, nowe )444 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat,ml_err)445 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat,ml_err)446 CASE ( 1 ) 447 CALL mppsend( 1, zt 3ew(1,1,1,1),imigr, nowe, ml_req1 )448 CALL mpprecv( 2, zt 3we(1,1,1,2),imigr, nowe )449 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat,ml_err)642 CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req1 ) 643 CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea ) 644 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 645 CASE ( 0 ) 646 CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 ) 647 CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req2 ) 648 CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea ) 649 CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe ) 650 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 651 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 652 CASE ( 1 ) 653 CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 ) 654 CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe ) 655 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 450 656 END SELECT 451 657 ! 452 658 ! ! Write Dirichlet lateral conditions 453 iihom = nlci-jpreci 454 ! 455 SELECT CASE ( nbondi ) 456 CASE ( -1 ) 457 DO jl = 1, jpreci 458 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 459 END DO 460 CASE ( 0 ) 461 DO jl = 1, jpreci 462 ptab(jl ,:,:) = zt3we(:,jl,:,2) 463 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 464 END DO 465 CASE ( 1 ) 466 DO jl = 1, jpreci 467 ptab(jl ,:,:) = zt3we(:,jl,:,2) 468 END DO 469 END SELECT 470 659 iihom = nlci - jpreci 660 ! 661 662 DO jf = 1 , kfld 663 SELECT CASE ( nbondi ) 664 CASE ( -1 ) 665 DO jl = 1, jpreci 666 pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf) 667 END DO 668 CASE ( 0 ) 669 DO jl = 1, jpreci 670 pt2d_array(jf)%pt2d( jl ,:) = zt2we(:,jl,kfld+jf) 671 pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf) 672 END DO 673 CASE ( 1 ) 674 DO jl = 1, jpreci 675 pt2d_array(jf)%pt2d( jl ,:)= zt2we(:,jl,kfld+jf) 676 END DO 677 END SELECT 678 END DO 679 471 680 ! 3. North and south directions 472 681 ! ----------------------------- 473 682 ! always closed : we play only with the neigbours 474 683 ! 475 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 476 ijhom = nlcj-nrecj 477 DO jl = 1, jprecj 478 zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 479 zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 480 END DO 481 ENDIF 684 !First Array 685 DO jf = 1 , kfld 686 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 687 ijhom = nlcj-nrecj 688 DO jl = 1, jprecj 689 zt2sn(:,jl,jf) = pt2d_array(jf)%pt2d(:, ijhom +jl ) 690 zt2ns(:,jl,jf) = pt2d_array(jf)%pt2d(:, jprecj+jl ) 691 END DO 692 ENDIF 693 END DO 482 694 ! 483 695 ! ! Migrations 484 imigr = jprecj * jpi * jpk696 imigr = jprecj * jpi 485 697 ! 486 698 SELECT CASE ( nbondj ) 487 699 CASE ( -1 ) 488 CALL mppsend( 4, zt 3sn(1,1,1,1),imigr, nono, ml_req1 )489 CALL mpprecv( 3, zt 3ns(1,1,1,2),imigr, nono )490 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)491 CASE ( 0 ) 492 CALL mppsend( 3, zt 3ns(1,1,1,1),imigr, noso, ml_req1 )493 CALL mppsend( 4, zt 3sn(1,1,1,1),imigr, nono, ml_req2 )494 CALL mpprecv( 3, zt 3ns(1,1,1,2),imigr, nono )495 CALL mpprecv( 4, zt 3sn(1,1,1,2),imigr, noso )496 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat,ml_err)497 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat,ml_err)498 CASE ( 1 ) 499 CALL mppsend( 3, zt 3ns(1,1,1,1),imigr, noso, ml_req1 )500 CALL mpprecv( 4, zt 3sn(1,1,1,2),imigr, noso )501 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat,ml_err)700 CALL mppsend( 4, zt2sn(1,1, 1), kfld*imigr, nono, ml_req1 ) 701 CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono ) 702 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 703 CASE ( 0 ) 704 CALL mppsend( 3, zt2ns(1,1, 1), kfld*imigr, noso, ml_req1 ) 705 CALL mppsend( 4, zt2sn(1,1, 1), kfld*imigr, nono, ml_req2 ) 706 CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono ) 707 CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso ) 708 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 709 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 710 CASE ( 1 ) 711 CALL mppsend( 3, zt2ns(1,1, 1), kfld*imigr, noso, ml_req1 ) 712 CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso ) 713 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 502 714 END SELECT 503 715 ! 504 716 ! ! Write Dirichlet lateral conditions 505 ijhom = nlcj-jprecj 506 ! 507 SELECT CASE ( nbondj ) 508 CASE ( -1 ) 509 DO jl = 1, jprecj 510 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 511 END DO 512 CASE ( 0 ) 513 DO jl = 1, jprecj 514 ptab(:,jl ,:) = zt3sn(:,jl,:,2) 515 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 516 END DO 517 CASE ( 1 ) 518 DO jl = 1, jprecj 519 ptab(:,jl,:) = zt3sn(:,jl,:,2) 520 END DO 521 END SELECT 522 717 ijhom = nlcj - jprecj 718 ! 719 DO jf = 1 , kfld 720 SELECT CASE ( nbondj ) 721 CASE ( -1 ) 722 DO jl = 1, jprecj 723 pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf ) 724 END DO 725 CASE ( 0 ) 726 DO jl = 1, jprecj 727 pt2d_array(jf)%pt2d(:, jl ) = zt2sn(:,jl, kfld+jf ) 728 pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf ) 729 END DO 730 CASE ( 1 ) 731 DO jl = 1, jprecj 732 pt2d_array(jf)%pt2d(:, jl ) = zt2sn(:,jl, kfld+jf ) 733 END DO 734 END SELECT 735 END DO 736 523 737 ! 4. north fold treatment 524 738 ! ----------------------- 525 739 ! 526 IF( npolj /= 0 .AND. .NOT. 740 IF( npolj /= 0 .AND. .NOT.PRESENT(cd_mpp) ) THEN 527 741 ! 528 742 SELECT CASE ( jpni ) 529 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 530 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 743 CASE ( 1 ) 744 DO jf = 1, kfld 745 CALL lbc_nfd( pt2d_array(jf)%pt2d(:,:), type_array(jf), psgn_array(jf) ) ! only 1 northern proc, no mpp 746 END DO 747 CASE DEFAULT 748 CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, kfld ) ! for all northern procs. 531 749 END SELECT 532 750 ! 533 751 ENDIF 534 752 ! 535 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 536 ! 537 END SUBROUTINE mpp_lnk_3d 538 539 540 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 541 !!---------------------------------------------------------------------- 542 !! *** routine mpp_lnk_2d_multiple *** 543 !! 544 !! ** Purpose : Message passing management for multiple 2d arrays 753 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 754 ! 755 END SUBROUTINE mpp_lnk_2d_multiple 756 757 758 SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, kfld ) 759 !!--------------------------------------------------------------------- 760 REAL(wp) , DIMENSION(:,:), TARGET, INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 761 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 762 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 763 TYPE(arrayptr) , DIMENSION(:) , INTENT(inout) :: pt2d_array ! 764 CHARACTER(len=1), DIMENSION(:) , INTENT(inout) :: type_array ! nature of pt2d_array array grid-points 765 REAL(wp) , DIMENSION(:) , INTENT(inout) :: psgn_array ! sign used across the north fold boundary 766 INTEGER , INTENT(inout) :: kfld ! 767 !!--------------------------------------------------------------------- 768 ! 769 kfld = kfld + 1 770 pt2d_array(kfld)%pt2d => pt2d 771 type_array(kfld) = cd_type 772 psgn_array(kfld) = psgn 773 ! 774 END SUBROUTINE load_array 775 776 777 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 778 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 779 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 780 !!--------------------------------------------------------------------- 781 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA ! 2D arrays on which the lbc is applied 782 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 783 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 784 CHARACTER(len=1) , INTENT(in ) :: cd_typeA ! nature of pt2D. array grid-points 785 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 786 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 787 REAL(wp) , INTENT(in ) :: psgnA ! sign used across the north fold 788 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 789 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 790 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 791 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 792 !! 793 INTEGER :: kfld 794 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 795 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 796 REAL(wp) , DIMENSION(9) :: psgn_array ! sign used across the north fold boundary 797 !!--------------------------------------------------------------------- 798 ! 799 kfld = 0 800 ! 801 ! ! Load the first array 802 CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, kfld ) 803 ! 804 ! ! Look if more arrays are added 805 IF( PRESENT(psgnB) ) CALL load_array( pt2dB, cd_typeB, psgnB, pt2d_array, type_array, psgn_array, kfld ) 806 IF( PRESENT(psgnC) ) CALL load_array( pt2dC, cd_typeC, psgnC, pt2d_array, type_array, psgn_array, kfld ) 807 IF( PRESENT(psgnD) ) CALL load_array( pt2dD, cd_typeD, psgnD, pt2d_array, type_array, psgn_array, kfld ) 808 IF( PRESENT(psgnE) ) CALL load_array( pt2dE, cd_typeE, psgnE, pt2d_array, type_array, psgn_array, kfld ) 809 IF( PRESENT(psgnF) ) CALL load_array( pt2dF, cd_typeF, psgnF, pt2d_array, type_array, psgn_array, kfld ) 810 IF( PRESENT(psgnG) ) CALL load_array( pt2dG, cd_typeG, psgnG, pt2d_array, type_array, psgn_array, kfld ) 811 IF( PRESENT(psgnH) ) CALL load_array( pt2dH, cd_typeH, psgnH, pt2d_array, type_array, psgn_array, kfld ) 812 IF( PRESENT(psgnI) ) CALL load_array( pt2dI, cd_typeI, psgnI, pt2d_array, type_array, psgn_array, kfld ) 813 ! 814 CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp,pval ) 815 ! 816 END SUBROUTINE mpp_lnk_2d_9 817 818 819 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 820 !!---------------------------------------------------------------------- 821 !! *** routine mpp_lnk_2d *** 822 !! 823 !! ** Purpose : Message passing manadgement for 2d array 545 824 !! 546 825 !! ** Method : Use mppsend and mpprecv function for passing mask … … 555 834 !! noso : number for local neighboring processors 556 835 !! nono : number for local neighboring processors 557 !! ----------------------------------------------------------------------558 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points559 ! ! = T , U , V , F , W and I points560 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary561 ! ! = 1. , the sign is kept562 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp! fill the overlap area only563 REAL(wp) , OPTIONAL , INTENT(in ) :: pval! background value (used at closed boundaries)836 !! 837 !!---------------------------------------------------------------------- 838 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 839 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 840 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 841 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 842 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 564 843 !! 565 844 INTEGER :: ji, jj, jl ! dummy loop indices 566 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES567 845 INTEGER :: imigr, iihom, ijhom ! temporary integers 568 846 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 569 INTEGER :: num_fields570 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array571 847 REAL(wp) :: zland 572 INTEGER , DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for key_mpi_isend848 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 573 849 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 574 850 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 575 576 !!---------------------------------------------------------------------- 577 ! 578 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 579 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 851 !!---------------------------------------------------------------------- 852 ! 853 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 854 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 580 855 ! 581 856 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value … … 586 861 ! ------------------------------ 587 862 ! 588 !First Array 589 DO ii = 1 , num_fields 590 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 591 ! 592 ! WARNING pt2d is defined only between nld and nle 593 DO jj = nlcj+1, jpj ! added line(s) (inner only) 594 pt2d_array(ii)%pt2d(nldi :nlei , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 595 pt2d_array(ii)%pt2d(1 :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi , nlej) 596 pt2d_array(ii)%pt2d(nlei+1:nlci , jj) = pt2d_array(ii)%pt2d( nlei, nlej) 597 END DO 598 DO ji = nlci+1, jpi ! added column(s) (full) 599 pt2d_array(ii)%pt2d(ji, nldj :nlej ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 600 pt2d_array(ii)%pt2d(ji, 1 :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj ) 601 pt2d_array(ii)%pt2d(ji, nlej+1:jpj ) = pt2d_array(ii)%pt2d(nlei, nlej) 602 END DO 603 ! 604 ELSE ! standard close or cyclic treatment 605 ! 606 ! ! East-West boundaries 607 IF( nbondi == 2 .AND. & ! Cyclic east-west 608 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 609 pt2d_array(ii)%pt2d( 1 , : ) = pt2d_array(ii)%pt2d( jpim1, : ) ! west 610 pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d( 2 , : ) ! east 611 ELSE ! closed 612 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( 1 : jpreci,:) = zland ! south except F-point 613 pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north 614 ENDIF 615 ! Noth-South boundaries 616 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south 617 pt2d_array(ii)%pt2d(:, 1 ) = pt2d_array(ii)%pt2d(:, jpjm1 ) 618 pt2d_array(ii)%pt2d(:, jpj ) = pt2d_array(ii)%pt2d(:, 2 ) 619 ELSE ! 620 ! ! North-South boundaries (closed) 621 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d(:, 1:jprecj ) = zland ! south except F-point 622 pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north 623 ! 624 ENDIF 625 ENDIF 626 END DO 863 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 864 ! 865 ! WARNING pt2d is defined only between nld and nle 866 DO jj = nlcj+1, jpj ! added line(s) (inner only) 867 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 868 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) 869 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) 870 END DO 871 DO ji = nlci+1, jpi ! added column(s) (full) 872 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej) 873 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj ) 874 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej) 875 END DO 876 ! 877 ELSE ! standard close or cyclic treatment 878 ! 879 ! ! East-West boundaries 880 IF( nbondi == 2 .AND. & !* cyclic 881 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 882 pt2d( 1 ,:) = pt2d(jpim1,:) ! west 883 pt2d(jpi,:) = pt2d( 2 ,:) ! east 884 ELSE !* closed 885 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 886 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 887 ENDIF 888 ! ! North-South boundaries 889 ! !* cyclic 890 IF( nbondj == 2 .AND. jperio == 7 ) THEN 891 pt2d(:, 1 ) = pt2d(:,jpjm1) 892 pt2d(:, jpj) = pt2d(:, 2) 893 ELSE !* closed 894 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point 895 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north 896 ENDIF 897 ENDIF 627 898 628 899 ! 2. East and west directions exchange … … 630 901 ! we play with the neigbours AND the row number because of the periodicity 631 902 ! 632 DO ii = 1 , num_fields 633 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 634 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 635 iihom = nlci-nreci 636 DO jl = 1, jpreci 637 zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 638 zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 639 END DO 640 END SELECT 641 END DO 903 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 904 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 905 iihom = nlci-nreci 906 DO jl = 1, jpreci 907 zt2ew(:,jl,1) = pt2d(jpreci+jl,:) 908 zt2we(:,jl,1) = pt2d(iihom +jl,:) 909 END DO 910 END SELECT 642 911 ! 643 912 ! ! Migrations … … 646 915 SELECT CASE ( nbondi ) 647 916 CASE ( -1 ) 648 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 )649 CALL mpprecv( 1, zt2ew(1,1, num_fields+1), num_fields*imigr, noea )917 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 918 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 650 919 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 651 920 CASE ( 0 ) 652 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 )653 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 )654 CALL mpprecv( 1, zt2ew(1,1, num_fields+1), num_fields*imigr, noea )655 CALL mpprecv( 2, zt2we(1,1, num_fields+1), num_fields*imigr, nowe )921 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 922 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 923 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 924 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 656 925 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 657 926 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 658 927 CASE ( 1 ) 659 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 )660 CALL mpprecv( 2, zt2we(1,1, num_fields+1), num_fields*imigr, nowe )928 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 929 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 661 930 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 662 931 END SELECT … … 665 934 iihom = nlci - jpreci 666 935 ! 667 668 DO ii = 1 , num_fields 669 SELECT CASE ( nbondi ) 670 CASE ( -1 ) 671 DO jl = 1, jpreci 672 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 673 END DO 674 CASE ( 0 ) 675 DO jl = 1, jpreci 676 pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 677 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 678 END DO 679 CASE ( 1 ) 680 DO jl = 1, jpreci 681 pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 682 END DO 683 END SELECT 684 END DO 685 936 SELECT CASE ( nbondi ) 937 CASE ( -1 ) 938 DO jl = 1, jpreci 939 pt2d(iihom+jl,:) = zt2ew(:,jl,2) 940 END DO 941 CASE ( 0 ) 942 DO jl = 1, jpreci 943 pt2d(jl ,:) = zt2we(:,jl,2) 944 pt2d(iihom+jl,:) = zt2ew(:,jl,2) 945 END DO 946 CASE ( 1 ) 947 DO jl = 1, jpreci 948 pt2d(jl ,:) = zt2we(:,jl,2) 949 END DO 950 END SELECT 951 686 952 ! 3. North and south directions 687 953 ! ----------------------------- 688 954 ! always closed : we play only with the neigbours 689 955 ! 690 !First Array 691 DO ii = 1 , num_fields 692 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 693 ijhom = nlcj-nrecj 694 DO jl = 1, jprecj 695 zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 696 zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 697 END DO 698 ENDIF 699 END DO 956 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 957 ijhom = nlcj-nrecj 958 DO jl = 1, jprecj 959 zt2sn(:,jl,1) = pt2d(:,ijhom +jl) 960 zt2ns(:,jl,1) = pt2d(:,jprecj+jl) 961 END DO 962 ENDIF 700 963 ! 701 964 ! ! Migrations … … 704 967 SELECT CASE ( nbondj ) 705 968 CASE ( -1 ) 706 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 )707 CALL mpprecv( 3, zt2ns(1,1, num_fields+1), num_fields*imigr, nono )969 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 970 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 708 971 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 709 972 CASE ( 0 ) 710 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 )711 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 )712 CALL mpprecv( 3, zt2ns(1,1, num_fields+1), num_fields*imigr, nono )713 CALL mpprecv( 4, zt2sn(1,1, num_fields+1), num_fields*imigr, noso )973 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 974 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 975 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 976 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 714 977 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 715 978 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 716 979 CASE ( 1 ) 717 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 )718 CALL mpprecv( 4, zt2sn(1,1, num_fields+1), num_fields*imigr, noso )980 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 981 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 719 982 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 720 983 END SELECT … … 723 986 ijhom = nlcj - jprecj 724 987 ! 725 726 DO ii = 1 , num_fields 727 !First Array 728 SELECT CASE ( nbondj ) 729 CASE ( -1 ) 730 DO jl = 1, jprecj 731 pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 732 END DO 733 CASE ( 0 ) 734 DO jl = 1, jprecj 735 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 736 pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 737 END DO 738 CASE ( 1 ) 739 DO jl = 1, jprecj 740 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 741 END DO 742 END SELECT 743 END DO 744 988 SELECT CASE ( nbondj ) 989 CASE ( -1 ) 990 DO jl = 1, jprecj 991 pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 992 END DO 993 CASE ( 0 ) 994 DO jl = 1, jprecj 995 pt2d(:,jl ) = zt2sn(:,jl,2) 996 pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 997 END DO 998 CASE ( 1 ) 999 DO jl = 1, jprecj 1000 pt2d(:,jl ) = zt2sn(:,jl,2) 1001 END DO 1002 END SELECT 1003 745 1004 ! 4. north fold treatment 746 1005 ! ----------------------- 747 1006 ! 748 !First Array749 1007 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 750 1008 ! 751 1009 SELECT CASE ( jpni ) 752 CASE ( 1 ) ; 753 DO ii = 1 , num_fields 754 CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 755 END DO 756 CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. 1010 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp 1011 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. 757 1012 END SELECT 758 1013 ! 759 1014 ENDIF 760 !761 1015 ! 762 1016 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 763 1017 ! 764 END SUBROUTINE mpp_lnk_2d_multiple 765 766 767 SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) 768 !!--------------------------------------------------------------------- 769 REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 770 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 771 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 772 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 773 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 774 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 775 INTEGER , INTENT (inout) :: num_fields 776 !!--------------------------------------------------------------------- 777 num_fields = num_fields + 1 778 pt2d_array(num_fields)%pt2d => pt2d 779 type_array(num_fields) = cd_type 780 psgn_array(num_fields) = psgn 781 END SUBROUTINE load_array 782 783 784 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 785 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 786 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 787 !!--------------------------------------------------------------------- 788 ! Second 2D array on which the boundary condition is applied 789 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 790 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 791 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 792 ! define the nature of ptab array grid-points 793 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 794 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 795 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 796 ! =-1 the sign change across the north fold boundary 797 REAL(wp) , INTENT(in ) :: psgnA 798 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 799 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 800 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 801 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 802 !! 803 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 804 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 805 ! ! = T , U , V , F , W and I points 806 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 807 INTEGER :: num_fields 808 !!--------------------------------------------------------------------- 809 ! 810 num_fields = 0 811 ! 812 ! Load the first array 813 CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 814 ! 815 ! Look if more arrays are added 816 IF( PRESENT(psgnB) ) CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 817 IF( PRESENT(psgnC) ) CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 818 IF( PRESENT(psgnD) ) CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 819 IF( PRESENT(psgnE) ) CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 820 IF( PRESENT(psgnF) ) CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 821 IF( PRESENT(psgnG) ) CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 822 IF( PRESENT(psgnH) ) CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 823 IF( PRESENT(psgnI) ) CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 824 ! 825 CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 826 ! 827 END SUBROUTINE mpp_lnk_2d_9 828 829 830 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 831 !!---------------------------------------------------------------------- 832 !! *** routine mpp_lnk_2d *** 833 !! 834 !! ** Purpose : Message passing manadgement for 2d array 1018 END SUBROUTINE mpp_lnk_2d 1019 1020 1021 SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 1022 !!---------------------------------------------------------------------- 1023 !! *** routine mpp_lnk_3d_gather *** 1024 !! 1025 !! ** Purpose : Message passing manadgement for two 3D arrays 835 1026 !! 836 1027 !! ** Method : Use mppsend and mpprecv function for passing mask … … 846 1037 !! nono : number for local neighboring processors 847 1038 !! 848 !!----------------------------------------------------------------------849 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied850 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points851 ! ! = T , U , V , F , W and I points852 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary853 ! ! = 1. , the sign is kept854 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only855 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)856 !!857 INTEGER :: ji, jj, jl ! dummy loop indices858 INTEGER :: imigr, iihom, ijhom ! temporary integers859 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend860 REAL(wp) :: zland861 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend862 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north863 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east864 !!----------------------------------------------------------------------865 !866 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &867 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )868 !869 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value870 ELSE ; zland = 0._wp ! zero by default871 ENDIF872 873 ! 1. standard boundary treatment874 ! ------------------------------875 !876 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values877 !878 ! WARNING pt2d is defined only between nld and nle879 DO jj = nlcj+1, jpj ! added line(s) (inner only)880 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej)881 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej)882 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej)883 END DO884 DO ji = nlci+1, jpi ! added column(s) (full)885 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej)886 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj )887 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej)888 END DO889 !890 ELSE ! standard close or cyclic treatment891 !892 ! ! East-West boundaries893 IF( nbondi == 2 .AND. & ! Cyclic east-west894 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN895 pt2d( 1 ,:) = pt2d(jpim1,:) ! west896 pt2d(jpi,:) = pt2d( 2 ,:) ! east897 ELSE ! closed898 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point899 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north900 ENDIF901 ! North-South boudaries902 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south903 pt2d(:, 1 ) = pt2d(:,jpjm1)904 pt2d(:, jpj) = pt2d(:, 2)905 ELSE906 ! ! North-South boundaries (closed)907 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point908 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north909 ENDIF910 ENDIF911 912 ! 2. East and west directions exchange913 ! ------------------------------------914 ! we play with the neigbours AND the row number because of the periodicity915 !916 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions917 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)918 iihom = nlci-nreci919 DO jl = 1, jpreci920 zt2ew(:,jl,1) = pt2d(jpreci+jl,:)921 zt2we(:,jl,1) = pt2d(iihom +jl,:)922 END DO923 END SELECT924 !925 ! ! Migrations926 imigr = jpreci * jpj927 !928 SELECT CASE ( nbondi )929 CASE ( -1 )930 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )931 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )932 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)933 CASE ( 0 )934 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )935 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )936 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )937 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )938 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)939 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)940 CASE ( 1 )941 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )942 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )943 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)944 END SELECT945 !946 ! ! Write Dirichlet lateral conditions947 iihom = nlci - jpreci948 !949 SELECT CASE ( nbondi )950 CASE ( -1 )951 DO jl = 1, jpreci952 pt2d(iihom+jl,:) = zt2ew(:,jl,2)953 END DO954 CASE ( 0 )955 DO jl = 1, jpreci956 pt2d(jl ,:) = zt2we(:,jl,2)957 pt2d(iihom+jl,:) = zt2ew(:,jl,2)958 END DO959 CASE ( 1 )960 DO jl = 1, jpreci961 pt2d(jl ,:) = zt2we(:,jl,2)962 END DO963 END SELECT964 965 966 ! 3. North and south directions967 ! -----------------------------968 ! always closed : we play only with the neigbours969 !970 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions971 ijhom = nlcj-nrecj972 DO jl = 1, jprecj973 zt2sn(:,jl,1) = pt2d(:,ijhom +jl)974 zt2ns(:,jl,1) = pt2d(:,jprecj+jl)975 END DO976 ENDIF977 !978 ! ! Migrations979 imigr = jprecj * jpi980 !981 SELECT CASE ( nbondj )982 CASE ( -1 )983 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )984 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )985 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)986 CASE ( 0 )987 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )988 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )989 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )990 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )991 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)992 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)993 CASE ( 1 )994 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )995 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )996 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)997 END SELECT998 !999 ! ! Write Dirichlet lateral conditions1000 ijhom = nlcj - jprecj1001 !1002 SELECT CASE ( nbondj )1003 CASE ( -1 )1004 DO jl = 1, jprecj1005 pt2d(:,ijhom+jl) = zt2ns(:,jl,2)1006 END DO1007 CASE ( 0 )1008 DO jl = 1, jprecj1009 pt2d(:,jl ) = zt2sn(:,jl,2)1010 pt2d(:,ijhom+jl) = zt2ns(:,jl,2)1011 END DO1012 CASE ( 1 )1013 DO jl = 1, jprecj1014 pt2d(:,jl ) = zt2sn(:,jl,2)1015 END DO1016 END SELECT1017 1018 1019 ! 4. north fold treatment1020 ! -----------------------1021 !1022 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN1023 !1024 SELECT CASE ( jpni )1025 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp1026 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.1027 END SELECT1028 !1029 ENDIF1030 !1031 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )1032 !1033 END SUBROUTINE mpp_lnk_2d1034 1035 1036 SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )1037 !!----------------------------------------------------------------------1038 !! *** routine mpp_lnk_3d_gather ***1039 !!1040 !! ** Purpose : Message passing manadgement for two 3D arrays1041 !!1042 !! ** Method : Use mppsend and mpprecv function for passing mask1043 !! between processors following neighboring subdomains.1044 !! domain parameters1045 !! nlci : first dimension of the local subdomain1046 !! nlcj : second dimension of the local subdomain1047 !! nbondi : mark for "east-west local boundary"1048 !! nbondj : mark for "north-south local boundary"1049 !! noea : number for local neighboring processors1050 !! nowe : number for local neighboring processors1051 !! noso : number for local neighboring processors1052 !! nono : number for local neighboring processors1053 !!1054 1039 !! ** Action : ptab1 and ptab2 with update value at its periphery 1055 1040 !! 1056 1041 !!---------------------------------------------------------------------- 1057 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which 1058 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab2 ! the boundary condition is applied 1059 CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays 1060 CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! i.e. grid-points = T , U , V , F or W points 1061 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1062 !! ! = 1. , the sign is kept 1063 INTEGER :: jl ! dummy loop indices 1042 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab1 ! 1st 3D array on which the boundary condition is applied 1043 CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 arrays 1044 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab2 ! 3nd 3D array on which the boundary condition is applied 1045 CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! nature of ptab2 arrays 1046 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 1047 ! 1048 INTEGER :: jl ! dummy loop indices 1049 INTEGER :: ipk ! 3rd dimension of the input array 1064 1050 INTEGER :: imigr, iihom, ijhom ! temporary integers 1065 1051 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend … … 1069 1055 !!---------------------------------------------------------------------- 1070 1056 ! 1071 ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) , & 1072 & zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 1073 ! 1057 ipk = SIZE( ptab1, 3 ) 1058 ! 1059 ALLOCATE( zt4ns(jpi,jprecj,ipk,2,2), zt4sn(jpi,jprecj,ipk,2,2) , & 1060 & zt4ew(jpj,jpreci,ipk,2,2), zt4we(jpj,jpreci,ipk,2,2) ) 1061 1074 1062 ! 1. standard boundary treatment 1075 1063 ! ------------------------------ 1076 1064 ! ! East-West boundaries 1077 ! !* Cyclic east-west1065 ! !* Cyclic 1078 1066 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1079 1067 ptab1( 1 ,:,:) = ptab1(jpim1,:,:) … … 1082 1070 ptab2(jpi,:,:) = ptab2( 2 ,:,:) 1083 1071 ELSE !* closed 1084 IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0.e0 ! south except at F-point 1085 IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0.e0 1086 ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 ! north 1087 ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0 1088 ENDIF 1089 ! North-South boundaries 1090 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south 1091 ptab1(:, 1 ,:) = ptab1(: , jpjm1 , :) 1092 ptab1(:, jpj ,:) = ptab1(: , 2 , :) 1093 ptab2(:, 1 ,:) = ptab2(: , jpjm1 , :) 1094 ptab2(:, jpj ,:) = ptab2(: , 2 , :) 1072 IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0._wp ! south except at F-point 1073 IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0._wp 1074 ptab1(nlci-jpreci+1:jpi ,:,:) = 0._wp ! north 1075 ptab2(nlci-jpreci+1:jpi ,:,:) = 0._wp 1076 ENDIF 1077 ! ! North-South boundaries 1078 ! !* cyclic 1079 IF( nbondj == 2 .AND. jperio == 7 ) THEN 1080 ptab1(:, 1 ,:) = ptab1(:, jpjm1 , :) 1081 ptab1(:, jpj ,:) = ptab1(:, 2 , :) 1082 ptab2(:, 1 ,:) = ptab2(:, jpjm1 , :) 1083 ptab2(:, jpj ,:) = ptab2(:, 2 , :) 1095 1084 ELSE 1096 ! ! North-South boundariesclosed1097 IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0.e0! south except at F-point1098 IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0.e01099 ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0! north1100 ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e01101 ENDIF 1085 ! !* closed 1086 IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0._wp ! south except at F-point 1087 IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0._wp 1088 ptab1(:,nlcj-jprecj+1:jpj ,:) = 0._wp ! north 1089 ptab2(:,nlcj-jprecj+1:jpj ,:) = 0._wp 1090 ENDIF 1102 1091 1103 1092 ! 2. East and west directions exchange … … 1117 1106 ! 1118 1107 ! ! Migrations 1119 imigr = jpreci * jpj * jpk *21108 imigr = jpreci * jpj * ipk *2 1120 1109 ! 1121 1110 SELECT CASE ( nbondi ) … … 1159 1148 END DO 1160 1149 END SELECT 1161 1162 1150 1163 1151 ! 3. North and south directions … … 1176 1164 ! 1177 1165 ! ! Migrations 1178 imigr = jprecj * jpi * jpk * 21166 imigr = jprecj * jpi * ipk * 2 1179 1167 ! 1180 1168 SELECT CASE ( nbondj ) … … 1218 1206 END DO 1219 1207 END SELECT 1220 1221 1208 1222 1209 ! 4. north fold treatment … … 1284 1271 1285 1272 1286 ! 1. standard boundary treatment 1273 ! 1. standard boundary treatment (CAUTION: the order matters Here !!!! ) 1287 1274 ! ------------------------------ 1288 ! Order matters Here !!!! 1289 ! 1290 ! North-South cyclic 1291 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south 1292 pt2d(:, 1-jprj: 1 ) = pt2d ( :, jpjm1-jprj:jpjm1) 1275 ! !== North-South boundaries 1276 ! !* cyclic 1277 IF( nbondj == 2 .AND. jperio == 7 ) THEN 1278 pt2d(:, 1-jprj: 1 ) = pt2d ( :, jpjm1-jprj:jpjm1 ) 1293 1279 pt2d(:, jpj :jpj+jprj) = pt2d ( :, 2 :2+jprj) 1294 ELSE 1295 1296 ! !* North-South boundaries (closed) 1297 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0.e0 ! south except at F-point 1298 pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0 ! north 1299 ENDIF 1300 1301 ! ! East-West boundaries 1302 ! !* Cyclic east-west 1280 ELSE !* closed 1281 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0._wp ! south except at F-point 1282 pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0._wp ! north 1283 ENDIF 1284 ! !== East-West boundaries 1285 ! !* Cyclic east-west 1303 1286 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1304 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 1305 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 1306 ! 1307 ELSE !* closed 1308 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point 1309 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north 1310 ENDIF 1311 ! 1312 1287 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 1288 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 1289 ELSE !* closed 1290 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point 1291 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north 1292 ENDIF 1293 ! 1313 1294 ! north fold treatment 1314 ! -------------------- ---1295 ! -------------------- 1315 1296 IF( npolj /= 0 ) THEN 1316 1297 ! 1317 1298 SELECT CASE ( jpni ) 1318 1299 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 1319 CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn)1300 CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn ) 1320 1301 END SELECT 1321 1302 ! … … 1375 1356 END SELECT 1376 1357 1377 1378 1358 ! 3. North and south directions 1379 1359 ! ----------------------------- … … 1429 1409 ! 1430 1410 END SUBROUTINE mpp_lnk_2d_e 1411 1431 1412 1432 1413 SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) … … 1452 1433 !!---------------------------------------------------------------------- 1453 1434 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 1454 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1455 ! ! = T , U , V , F , W points 1456 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1457 ! ! = 1. , the sign is kept 1435 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 1436 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 1458 1437 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1459 1438 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 1460 ! !1439 ! 1461 1440 INTEGER :: ji, jj, jk, jl ! dummy loop indices 1462 1441 INTEGER :: imigr, iihom, ijhom ! temporary integers … … 1467 1446 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 1468 1447 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 1469 1470 !!---------------------------------------------------------------------- 1471 1448 !!---------------------------------------------------------------------- 1449 ! 1472 1450 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 1473 1451 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 1474 1475 1452 ! 1476 1453 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1477 ELSE ; zland = 0. e0! zero by default1454 ELSE ; zland = 0._wp ! zero by default 1478 1455 ENDIF 1479 1456 … … 1488 1465 iihom = nlci-jpreci 1489 1466 DO jl = 1, jpreci 1490 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0. 0_wp1491 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0. 0_wp1467 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0._wp 1468 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0._wp 1492 1469 END DO 1493 1470 END SELECT … … 1520 1497 CASE ( -1 ) 1521 1498 DO jl = 1, jpreci 1522 ptab(iihom +jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2)1499 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 1523 1500 END DO 1524 1501 CASE ( 0 ) … … 1533 1510 END SELECT 1534 1511 1535 1536 1512 ! 3. North and south directions 1537 1513 ! ----------------------------- … … 1541 1517 ijhom = nlcj-jprecj 1542 1518 DO jl = 1, jprecj 1543 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp1544 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0.0_wp1519 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0._wp 1520 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0._wp 1545 1521 END DO 1546 1522 ENDIF … … 1586 1562 END SELECT 1587 1563 1588 1589 1564 ! 4. north fold treatment 1590 1565 ! ----------------------- … … 1602 1577 ! 1603 1578 END SUBROUTINE mpp_lnk_sum_3d 1579 1604 1580 1605 1581 SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) … … 1620 1596 !! noso : number for local neighboring processors 1621 1597 !! nono : number for local neighboring processors 1622 !!1623 1598 !!---------------------------------------------------------------------- 1624 1599 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 1625 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1626 ! ! = T , U , V , F , W and I points 1627 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1628 ! ! = 1. , the sign is kept 1600 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points 1601 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 1629 1602 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1630 1603 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) … … 1638 1611 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 1639 1612 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 1640 1641 !!---------------------------------------------------------------------- 1642 1613 !!---------------------------------------------------------------------- 1614 ! 1643 1615 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 1644 1616 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 1645 1646 1617 ! 1647 1618 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1648 ELSE ; zland = 0. e0! zero by default1619 ELSE ; zland = 0._wp ! zero by default 1649 1620 ENDIF 1650 1621 … … 1757 1728 END SELECT 1758 1729 1759 1760 1730 ! 4. north fold treatment 1761 1731 ! ----------------------- … … 1773 1743 ! 1774 1744 END SUBROUTINE mpp_lnk_sum_2d 1745 1775 1746 1776 1747 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) … … 2015 1986 !! *** routine mppmax_a_real *** 2016 1987 !! 2017 !! ** Purpose : Maximum 1988 !! ** Purpose : Maximum of a 1D array 2018 1989 !! 2019 1990 !!---------------------------------------------------------------------- … … 2039 2010 !! *** routine mppmax_real *** 2040 2011 !! 2041 !! ** Purpose : Maximum 2012 !! ** Purpose : Maximum for each element of a 1D array 2042 2013 !! 2043 2014 !!---------------------------------------------------------------------- … … 2057 2028 END SUBROUTINE mppmax_real 2058 2029 2059 SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) 2030 2031 SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom ) 2060 2032 !!---------------------------------------------------------------------- 2061 2033 !! *** routine mppmax_real *** … … 2064 2036 !! 2065 2037 !!---------------------------------------------------------------------- 2066 REAL(wp), DIMENSION( :) , INTENT(inout) :: ptab ! ???2067 INTEGER , INTENT(in ) :: NUM2068 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ???2038 REAL(wp), DIMENSION(kdim), INTENT(inout) :: pt1d ! 1D arrays 2039 INTEGER , INTENT(in ) :: kdim 2040 INTEGER , OPTIONAL , INTENT(in ) :: kcom ! local communicator 2069 2041 !! 2070 2042 INTEGER :: ierror, localcomm 2071 REAL(wp) , POINTER , DIMENSION(:) :: zwork 2072 !!---------------------------------------------------------------------- 2073 ! 2074 CALL wrk_alloc(NUM , zwork) 2043 !!---------------------------------------------------------------------- 2044 ! 2075 2045 localcomm = mpi_comm_opa 2076 2046 IF( PRESENT(kcom) ) localcomm = kcom 2077 2047 ! 2078 CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 2079 ptab = zwork 2080 CALL wrk_dealloc(NUM , zwork) 2048 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 2049 ptab(:) = zwork(:) 2081 2050 ! 2082 2051 END SUBROUTINE mppmax_real_multiple … … 2251 2220 !!----------------------------------------------------------------------- 2252 2221 ! 2253 zmin = MINVAL( ptab(:,:) , mask= pmask == 1. e0)2254 ilocs = MINLOC( ptab(:,:) , mask= pmask == 1. e0)2222 zmin = MINVAL( ptab(:,:) , mask= pmask == 1._wp ) 2223 ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp ) 2255 2224 ! 2256 2225 ki = ilocs(1) + nimpp - 1 … … 2279 2248 !! 2280 2249 !!-------------------------------------------------------------------------- 2281 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array2282 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask2283 REAL(wp) 2284 INTEGER 2285 ! !2250 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! Local 2D array 2251 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! Local mask 2252 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 2253 INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame 2254 ! 2286 2255 INTEGER :: ierror 2287 2256 REAL(wp) :: zmin ! local minimum … … 2290 2259 !!----------------------------------------------------------------------- 2291 2260 ! 2292 zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1. e0)2293 ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1. e0)2261 zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 2262 ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 2294 2263 ! 2295 2264 ki = ilocs(1) + nimpp - 1 … … 2297 2266 kk = ilocs(3) 2298 2267 ! 2299 zain(1,:) =zmin2300 zain(2,:) =ki+10000.*kj+100000000.*kk2268 zain(1,:) = zmin 2269 zain(2,:) = ki + 10000.*kj + 100000000.*kk 2301 2270 ! 2302 2271 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) … … 2331 2300 !!----------------------------------------------------------------------- 2332 2301 ! 2333 zmax = MAXVAL( ptab(:,:) , mask= pmask == 1. e0)2334 ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1. e0)2302 zmax = MAXVAL( ptab(:,:) , mask= pmask == 1._wp ) 2303 ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp ) 2335 2304 ! 2336 2305 ki = ilocs(1) + nimpp - 1 … … 2359 2328 !! 2360 2329 !!-------------------------------------------------------------------------- 2361 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array 2362 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask 2363 REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab 2364 INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame 2365 !! 2366 REAL(wp) :: zmax ! local maximum 2330 REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: ptab ! Local 2D array 2331 REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: pmask ! Local mask 2332 REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab 2333 INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame 2334 ! 2335 INTEGER :: ierror ! local integer 2336 REAL(wp) :: zmax ! local maximum 2367 2337 REAL(wp), DIMENSION(2,1) :: zain, zaout 2368 2338 INTEGER , DIMENSION(3) :: ilocs 2369 INTEGER :: ierror2370 2339 !!----------------------------------------------------------------------- 2371 2340 ! 2372 zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1. e0)2373 ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1. e0)2341 zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 2342 ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 2374 2343 ! 2375 2344 ki = ilocs(1) + nimpp - 1 … … 2377 2346 kk = ilocs(3) 2378 2347 ! 2379 zain(1,:) =zmax2380 zain(2,:) =ki+10000.*kj+100000000.*kk2348 zain(1,:) = zmax 2349 zain(2,:) = ki + 10000.*kj + 100000000.*kk 2381 2350 ! 2382 2351 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) … … 2422 2391 2423 2392 SUBROUTINE mpp_comm_free( kcom ) 2424 !!----------------------------------------------------------------------2425 2393 !!---------------------------------------------------------------------- 2426 2394 INTEGER, INTENT(in) :: kcom … … 2692 2660 !! and apply lbc north-fold on this sub array. Then we 2693 2661 !! scatter the north fold array back to the processors. 2694 !! 2695 !!---------------------------------------------------------------------- 2696 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied 2697 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2698 ! ! = T , U , V , F or W gridpoints 2699 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2700 !! ! = 1. , the sign is kept 2662 !!---------------------------------------------------------------------- 2663 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied 2664 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2665 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 2666 ! 2701 2667 INTEGER :: ji, jj, jr, jk 2668 INTEGER :: ipk ! 3rd dimension of the input array 2702 2669 INTEGER :: ierr, itaille, ildi, ilei, iilb 2703 2670 INTEGER :: ijpj, ijpjm1, ij, iproc … … 2715 2682 !!---------------------------------------------------------------------- 2716 2683 ! 2717 ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) ) 2718 ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) ) 2684 ipk = SIZE( pt3d, 3 ) 2685 ! 2686 ALLOCATE( ztab (jpiglo,4,ipk), znorthloc(jpi,4,ipk), zfoldwk(jpi,4,ipk), znorthgloio(jpi,4,ipk,jpni) ) 2687 ALLOCATE( ztabl(jpi ,4,ipk), ztabr(jpi*jpmaxngh,4,ipk) ) 2719 2688 2720 2689 ijpj = 4 2721 2690 ijpjm1 = 3 2722 2691 ! 2723 znorthloc(:,:,:) = 0 2724 DO jk = 1, jpk2692 znorthloc(:,:,:) = 0._wp 2693 DO jk = 1, ipk 2725 2694 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d 2726 2695 ij = jj - nlcj + ijpj … … 2730 2699 ! 2731 2700 ! ! Build in procs of ncomm_north the znorthgloio 2732 itaille = jpi * jpk * ijpj2701 itaille = jpi * ipk * ijpj 2733 2702 2734 2703 IF ( l_north_nogather ) THEN 2735 2704 ! 2736 ztabr(:,:,:) = 0 2737 ztabl(:,:,:) = 0 2738 2739 DO jk = 1, jpk2705 ztabr(:,:,:) = 0._wp 2706 ztabl(:,:,:) = 0._wp 2707 2708 DO jk = 1, ipk 2740 2709 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2741 2710 ij = jj - nlcj + ijpj … … 2747 2716 2748 2717 DO jr = 1,nsndto 2749 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne.-1)) THEN2718 IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN 2750 2719 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 2751 2720 ENDIF … … 2753 2722 DO jr = 1,nsndto 2754 2723 iproc = nfipproc(isendto(jr),jpnj) 2755 IF(iproc .ne.-1) THEN2724 IF(iproc /= -1) THEN 2756 2725 ilei = nleit (iproc+1) 2757 2726 ildi = nldit (iproc+1) 2758 2727 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2759 2728 ENDIF 2760 IF((iproc .ne. (narea-1)) .and. (iproc .ne.-1)) THEN2729 IF((iproc /= (narea-1)) .and. (iproc /= -1)) THEN 2761 2730 CALL mpprecv(5, zfoldwk, itaille, iproc) 2762 DO jk = 1, jpk2731 DO jk = 1, ipk 2763 2732 DO jj = 1, ijpj 2764 2733 DO ji = ildi, ilei … … 2767 2736 END DO 2768 2737 END DO 2769 ELSE IF (iproc .eq. (narea-1)) THEN2770 DO jk = 1, jpk2738 ELSE IF( iproc == narea-1 ) THEN 2739 DO jk = 1, ipk 2771 2740 DO jj = 1, ijpj 2772 2741 DO ji = ildi, ilei … … 2779 2748 IF (l_isend) THEN 2780 2749 DO jr = 1,nsndto 2781 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne.-1)) THEN2750 IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN 2782 2751 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2783 2752 ENDIF … … 2785 2754 ENDIF 2786 2755 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition 2787 DO jk = 1, jpk2756 DO jk = 1, ipk 2788 2757 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2789 2758 ij = jj - nlcj + ijpj … … 2794 2763 END DO 2795 2764 ! 2796 2797 2765 ELSE 2798 2766 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & 2799 2767 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2800 2768 ! 2801 ztab(:,:,:) = 0. e02769 ztab(:,:,:) = 0._wp 2802 2770 DO jr = 1, ndim_rank_north ! recover the global north array 2803 2771 iproc = nrank_north(jr) + 1 … … 2805 2773 ilei = nleit (iproc) 2806 2774 iilb = nimppt(iproc) 2807 DO jk = 1, jpk2775 DO jk = 1, ipk 2808 2776 DO jj = 1, ijpj 2809 2777 DO ji = ildi, ilei … … 2815 2783 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition 2816 2784 ! 2817 DO jk = 1, jpk2785 DO jk = 1, ipk 2818 2786 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2819 2787 ij = jj - nlcj + ijpj … … 2902 2870 2903 2871 DO jr = 1,nsndto 2904 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne.-1)) THEN2872 IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN 2905 2873 CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) 2906 2874 ENDIF … … 2908 2876 DO jr = 1,nsndto 2909 2877 iproc = nfipproc(isendto(jr),jpnj) 2910 IF(iproc .ne.-1) THEN2878 IF(iproc /= -1) THEN 2911 2879 ilei = nleit (iproc+1) 2912 2880 ildi = nldit (iproc+1) 2913 2881 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2914 2882 ENDIF 2915 IF( (iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN2883 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 2916 2884 CALL mpprecv(5, zfoldwk, itaille, iproc) 2917 2885 DO jj = 1, ijpj … … 2920 2888 END DO 2921 2889 END DO 2922 ELSE IF (iproc .eq. (narea-1)) THEN2890 ELSE IF( iproc == narea-1 ) THEN 2923 2891 DO jj = 1, ijpj 2924 2892 DO ji = ildi, ilei … … 2930 2898 IF (l_isend) THEN 2931 2899 DO jr = 1,nsndto 2932 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne.-1)) THEN2900 IF ((nfipproc(isendto(jr),jpnj) /= (narea-1)) .and. (nfipproc(isendto(jr),jpnj) /= -1)) THEN 2933 2901 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2934 2902 ENDIF … … 2948 2916 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2949 2917 ! 2950 ztab(:,:) = 0. e02918 ztab(:,:) = 0._wp 2951 2919 DO jr = 1, ndim_rank_north ! recover the global north array 2952 2920 iproc = nrank_north(jr) + 1 … … 2975 2943 END SUBROUTINE mpp_lbc_north_2d 2976 2944 2977 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 2945 2946 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, kfld ) 2978 2947 !!--------------------------------------------------------------------- 2979 2948 !! *** routine mpp_lbc_north_2d *** … … 2990 2959 !! 2991 2960 !!---------------------------------------------------------------------- 2992 INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d 2993 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 2994 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2995 ! ! = T , U , V , F or W gridpoints 2996 REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2997 !! ! = 1. , the sign is kept 2961 TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields 2962 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2963 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold 2964 INTEGER , INTENT(in ) :: kfld ! number of variables contained in pt2d 2965 ! 2998 2966 INTEGER :: ji, jj, jr, jk 2999 2967 INTEGER :: ierr, itaille, ildi, ilei, iilb 3000 INTEGER :: ijpj, ijpjm1, ij, iproc 3001 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 3002 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 3003 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 3004 ! ! Workspace for message transfers avoiding mpi_allgather 2968 INTEGER :: ijpj, ijpjm1, ij, iproc, iflag 2969 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 2970 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2971 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2972 ! ! Workspace for message transfers avoiding mpi_allgather 2973 INTEGER :: istatus(mpi_status_size) 3005 2974 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab 3006 2975 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 3007 2976 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 3008 2977 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 3009 INTEGER :: istatus(mpi_status_size) 3010 INTEGER :: iflag 3011 !!---------------------------------------------------------------------- 3012 ! 3013 ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), & 3014 & znorthgloio(jpi,4,num_fields,jpni) ) ! expanded to 3 dimensions 3015 ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 2978 !!---------------------------------------------------------------------- 2979 ! 2980 ALLOCATE( ztab(jpiglo,4,kfld), znorthloc (jpi,4,kfld), & 2981 & zfoldwk(jpi,4,kfld), znorthgloio(jpi,4,kfld,jpni), & 2982 & ztabl (jpi,4,kfld), ztabr(jpi*jpmaxngh, 4,kfld) ) 3016 2983 ! 3017 2984 ijpj = 4 … … 3019 2986 ! 3020 2987 3021 DO jk = 1, num_fields2988 DO jk = 1, kfld 3022 2989 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable) 3023 2990 ij = jj - nlcj + ijpj … … 3033 3000 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 3034 3001 ! 3035 ztabr(:,:,:) = 0 3036 ztabl(:,:,:) = 0 3037 3038 DO jk = 1, num_fields3002 ztabr(:,:,:) = 0._wp 3003 ztabl(:,:,:) = 0._wp 3004 3005 DO jk = 1, kfld 3039 3006 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 3040 3007 ij = jj - nlcj + ijpj … … 3045 3012 END DO 3046 3013 3047 DO jr = 1, nsndto3048 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN3049 CALL mppsend(5, znorthloc, itaille* num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times3014 DO jr = 1, nsndto 3015 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 3016 CALL mppsend(5, znorthloc, itaille*kfld, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "kfld" times 3050 3017 ENDIF 3051 3018 END DO 3052 DO jr = 1, nsndto3019 DO jr = 1, nsndto 3053 3020 iproc = nfipproc(isendto(jr),jpnj) 3054 IF(iproc .ne.-1) THEN3021 IF(iproc /= -1) THEN 3055 3022 ilei = nleit (iproc+1) 3056 3023 ildi = nldit (iproc+1) 3057 3024 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 3058 3025 ENDIF 3059 IF( (iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN3060 CALL mpprecv(5, zfoldwk, itaille* num_fields, iproc) ! Buffer expanded "num_fields" times3061 DO jk = 1 , num_fields3026 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 3027 CALL mpprecv(5, zfoldwk, itaille*kfld, iproc) ! Buffer expanded "kfld" times 3028 DO jk = 1 , kfld 3062 3029 DO jj = 1, ijpj 3063 3030 DO ji = ildi, ilei … … 3066 3033 END DO 3067 3034 END DO 3068 ELSE IF (iproc .eq. (narea-1)) THEN3069 DO jk = 1, num_fields3035 ELSEIF ( iproc == narea-1 ) THEN 3036 DO jk = 1, kfld 3070 3037 DO jj = 1, ijpj 3071 3038 DO ji = ildi, ilei … … 3076 3043 ENDIF 3077 3044 END DO 3078 IF (l_isend) THEN3079 DO jr = 1, nsndto3080 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN3045 IF( l_isend ) THEN 3046 DO jr = 1, nsndto 3047 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 3081 3048 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 3082 3049 ENDIF … … 3084 3051 ENDIF 3085 3052 ! 3086 DO ji = 1, num_fields! Loop to manage 3D variables3053 DO ji = 1, kfld ! Loop to manage 3D variables 3087 3054 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 3088 3055 END DO 3089 3056 ! 3090 DO jk = 1, num_fields3057 DO jk = 1, kfld 3091 3058 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 3092 3059 ij = jj - nlcj + ijpj … … 3100 3067 ELSE 3101 3068 ! 3102 CALL MPI_ALLGATHER( znorthloc , itaille* num_fields, MPI_DOUBLE_PRECISION, &3103 & znorthgloio, itaille* num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr )3104 ! 3105 ztab(:,:,:) = 0. e03106 DO jk = 1, num_fields3069 CALL MPI_ALLGATHER( znorthloc , itaille*kfld, MPI_DOUBLE_PRECISION, & 3070 & znorthgloio, itaille*kfld, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 3071 ! 3072 ztab(:,:,:) = 0._wp 3073 DO jk = 1, kfld 3107 3074 DO jr = 1, ndim_rank_north ! recover the global north array 3108 3075 iproc = nrank_north(jr) + 1 … … 3118 3085 END DO 3119 3086 3120 DO ji = 1, num_fields3087 DO ji = 1, kfld 3121 3088 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 3122 3089 END DO 3123 3090 ! 3124 DO jk = 1, num_fields3091 DO jk = 1, kfld 3125 3092 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 3126 3093 ij = jj - nlcj + ijpj … … 3138 3105 END SUBROUTINE mpp_lbc_north_2d_multiple 3139 3106 3107 3140 3108 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 3141 3109 !!--------------------------------------------------------------------- … … 3155 3123 REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo 3156 3124 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 3157 ! ! = T , U , V , F or W -points 3158 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 3159 !! ! north fold, = 1. otherwise 3125 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 3126 ! 3160 3127 INTEGER :: ji, jj, jr 3161 3128 INTEGER :: ierr, itaille, ildi, ilei, iilb 3162 3129 INTEGER :: ijpj, ij, iproc 3163 !3164 3130 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 3165 3131 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 3166 3167 3132 !!---------------------------------------------------------------------- 3168 3133 ! 3169 3134 ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 3170 3171 3135 ! 3172 3136 ijpj=4 3173 ztab_e(:,:) = 0. e03174 3175 ij =03137 ztab_e(:,:) = 0._wp 3138 3139 ij = 0 3176 3140 ! put in znorthloc_e the last 4 jlines of pt2d 3177 3141 DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 3178 3142 ij = ij + 1 3179 3143 DO ji = 1, jpi 3180 znorthloc_e(ji,ij) =pt2d(ji,jj)3144 znorthloc_e(ji,ij) = pt2d(ji,jj) 3181 3145 END DO 3182 3146 END DO 3183 3147 ! 3184 3148 itaille = jpi * ( ijpj + 2 * jpr2dj ) 3185 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &3149 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 3186 3150 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 3187 3151 ! 3188 3152 DO jr = 1, ndim_rank_north ! recover the global north array 3189 3153 iproc = nrank_north(jr) + 1 3190 ildi = nldit (iproc)3191 ilei = nleit (iproc)3192 iilb = nimppt(iproc)3154 ildi = nldit (iproc) 3155 ilei = nleit (iproc) 3156 iilb = nimppt(iproc) 3193 3157 DO jj = 1, ijpj+2*jpr2dj 3194 3158 DO ji = ildi, ilei … … 3197 3161 END DO 3198 3162 END DO 3199 3200 3163 3201 3164 ! 2. North-Fold boundary conditions … … 3238 3201 !! 3239 3202 !!---------------------------------------------------------------------- 3240 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3241 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 3242 ! ! = T , U , V , F , W points 3243 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 3244 ! ! = 1. , the sign is kept 3245 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3203 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3204 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab grid point 3205 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 3206 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3246 3207 ! 3247 3208 INTEGER :: ji, jj, jk, jl ! dummy loop indices 3209 INTEGER :: ipk ! 3rd dimension of the input array 3248 3210 INTEGER :: imigr, iihom, ijhom ! local integers 3249 3211 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend … … 3255 3217 !!---------------------------------------------------------------------- 3256 3218 ! 3257 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 3258 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 3219 ipk = SIZE( ptab, 3 ) 3220 ! 3221 ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2), & 3222 & zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2) ) 3259 3223 3260 3224 zland = 0._wp … … 3263 3227 ! ------------------------------ 3264 3228 ! ! East-West boundaries 3265 ! !* Cyclic east-west3229 ! !* Cyclic 3266 3230 IF( nbondi == 2) THEN 3267 3231 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN … … 3273 3237 ENDIF 3274 3238 ELSEIF(nbondi == -1) THEN 3275 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point3239 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 3276 3240 ELSEIF(nbondi == 1) THEN 3277 3241 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north … … 3298 3262 ! 3299 3263 ! ! Migrations 3300 imigr = jpreci * jpj * jpk3264 imigr = jpreci * jpj * ipk 3301 3265 ! 3302 3266 SELECT CASE ( nbondi_bdy(ib_bdy) ) … … 3348 3312 END DO 3349 3313 END SELECT 3350 3351 3314 3352 3315 ! 3. North and south directions … … 3363 3326 ! 3364 3327 ! ! Migrations 3365 imigr = jprecj * jpi * jpk3328 imigr = jprecj * jpi * ipk 3366 3329 ! 3367 3330 SELECT CASE ( nbondj_bdy(ib_bdy) ) … … 3413 3376 END DO 3414 3377 END SELECT 3415 3416 3378 3417 3379 ! 4. north fold treatment … … 3453 3415 !! 3454 3416 !!---------------------------------------------------------------------- 3455 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3456 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 3457 ! ! = T , U , V , F , W points 3458 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 3459 ! ! = 1. , the sign is kept 3460 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3461 ! 3462 INTEGER :: ji, jj, jl ! dummy loop indices 3417 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3418 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3419 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary 3420 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3421 ! 3422 INTEGER :: ji, jj, jl ! dummy loop indices 3463 3423 INTEGER :: imigr, iihom, ijhom ! local integers 3464 3424 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend … … 3478 3438 ! ------------------------------ 3479 3439 ! ! East-West boundaries 3480 ! !* Cyclic east-west3440 ! !* Cyclic 3481 3441 IF( nbondi == 2 ) THEN 3482 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN3442 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 3483 3443 ptab( 1 ,:) = ptab(jpim1,:) 3484 3444 ptab(jpi,:) = ptab( 2 ,:) 3485 3445 ELSE 3486 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point3487 ptab(nlci-jpreci+1:jpi ,:) = zland ! north3446 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3447 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3488 3448 ENDIF 3489 3449 ELSEIF(nbondi == -1) THEN 3490 IF( .NOT.cd_type == 'F' )ptab( 1 :jpreci,:) = zland ! south except F-point3450 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3491 3451 ELSEIF(nbondi == 1) THEN 3492 ptab(nlci-jpreci+1:jpi ,:) = zland ! north3452 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3493 3453 ENDIF 3494 3454 ! !* closed … … 3537 3497 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3538 3498 CASE ( -1 ) 3539 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3540 CASE ( 0 ) 3541 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3542 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )3543 CASE ( 1 ) 3544 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3499 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 3500 CASE ( 0 ) 3501 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 3502 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 3503 CASE ( 1 ) 3504 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 3545 3505 END SELECT 3546 3506 ! … … 3628 3588 END DO 3629 3589 END SELECT 3630 3631 3590 3632 3591 ! 4. north fold treatment … … 3713 3672 !! This subroutine computes yddb(i) = ydda(i)+yddb(i) 3714 3673 !!--------------------------------------------------------------------- 3715 INTEGER , INTENT(in) ::ilen, itype3716 COMPLEX(wp), DIMENSION(ilen), INTENT(in) ::ydda3717 COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::yddb3674 INTEGER , INTENT(in) :: ilen, itype 3675 COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda 3676 COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb 3718 3677 ! 3719 3678 REAL(wp) :: zerr, zt1, zt2 ! local work variables 3720 INTEGER :: ji, ztmp ! local scalar 3679 INTEGER :: ji, ztmp ! local scalar 3680 !!--------------------------------------------------------------------- 3721 3681 3722 3682 ztmp = itype ! avoid compilation warning … … 3841 3801 !! nono : number for local neighboring processors 3842 3802 !!---------------------------------------------------------------------- 3803 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 3804 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3805 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 3843 3806 INTEGER , INTENT(in ) :: jpri 3844 3807 INTEGER , INTENT(in ) :: jprj 3845 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 3846 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3847 ! ! = T , U , V , F , W and I points 3848 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the 3849 !! ! north boundary, = 1. otherwise 3808 ! 3850 3809 INTEGER :: jl ! dummy loop indices 3851 3810 INTEGER :: imigr, iihom, ijhom ! temporary integers … … 3875 3834 ! 3876 3835 ELSE !* closed 3877 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0. e0! south except at F-point3878 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0. e0! north3836 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point 3837 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north 3879 3838 ENDIF 3880 3839 ! … … 3996 3955 END DO 3997 3956 END SELECT 3998 3957 ! 3999 3958 END SUBROUTINE mpp_lnk_2d_icb 4000 3959 … … 4020 3979 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 4021 3980 END INTERFACE 3981 INTERFACE mpp_max_multiple 3982 MODULE PROCEDURE mppmax_real_multiple 3983 END INTERFACE 4022 3984 4023 3985 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag … … 4191 4153 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 4192 4154 END SUBROUTINE mpp_comm_free 4155 4156 SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom ) 4157 REAL, DIMENSION(:) :: ptab ! 4158 INTEGER :: kdim ! 4159 INTEGER, OPTIONAL :: kcom ! 4160 WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim 4161 END SUBROUTINE mppmax_real_multiple 4162 4193 4163 #endif 4194 4164 … … 4225 4195 CALL FLUSH(numout ) 4226 4196 IF( numstp /= -1 ) CALL FLUSH(numstp ) 4227 IF( num sol /= -1 ) CALL FLUSH(numsol)4197 IF( numrun /= -1 ) CALL FLUSH(numrun ) 4228 4198 IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice) 4229 4199 ! … … 4332 4302 WRITE(kout,*) 4333 4303 ENDIF 4334 CALL FLUSH( kout)4304 CALL FLUSH( kout ) 4335 4305 STOP 'ctl_opn bad opening' 4336 4306 ENDIF
Note: See TracChangeset
for help on using the changeset viewer.