- Timestamp:
- 2016-01-08T10:35:19+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4704_NOC5_MPP_BDY_UPDATE/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4671 r6225 23 23 !! the mppobc routine to optimize the BDY and OBC communications 24 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 26 !!---------------------------------------------------------------------- 27 27 28 28 !!---------------------------------------------------------------------- 29 !! ctl_stop : update momentum and tracer Kz from a tke scheme30 !! ctl_warn : initialization, namelist read, and parameters control31 !! ctl_opn : Open file and check if required file is available.32 !! ctl_nam : Prints informations when an error occurs while reading a namelist33 !! get_unit : give the index of an unused logical unit29 !! ctl_stop : update momentum and tracer Kz from a tke scheme 30 !! ctl_warn : initialization, namelist read, and parameters control 31 !! ctl_opn : Open file and check if required file is available. 32 !! ctl_nam : Prints informations when an error occurs while reading a namelist 33 !! get_unit : give the index of an unused logical unit 34 34 !!---------------------------------------------------------------------- 35 35 #if defined key_mpp_mpi … … 42 42 !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays 43 43 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 44 !! mpprecv : 44 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 45 !! mpprecv : 45 46 !! mppsend : SUBROUTINE mpp_ini_znl 46 47 !! mppscatter : … … 56 57 !! mpp_lbc_north : north fold processors gathering 57 58 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 59 !! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 58 60 !!---------------------------------------------------------------------- 59 61 USE dom_oce ! ocean space and time domain … … 69 71 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 70 72 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 PUBLIC mpp_lnk_2d_9 74 PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 71 75 PUBLIC mppscatter, mppgather 72 76 PUBLIC mpp_ini_ice, mpp_ini_znl … … 74 78 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 75 79 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 76 80 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 81 82 TYPE arrayptr 83 REAL , DIMENSION (:,:), POINTER :: pt2d 84 END TYPE arrayptr 85 77 86 !! * Interfaces 78 87 !! define generic interface for these routine as they are called sometimes … … 86 95 END INTERFACE 87 96 INTERFACE mpp_sum 88 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &97 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 89 98 mppsum_realdd, mppsum_a_realdd 90 99 END INTERFACE … … 161 170 162 171 163 FUNCTION mynode( ldtxt, kumnam_ref , kumnam_cfg , kumond , kstop, localComm )172 FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 164 173 !!---------------------------------------------------------------------- 165 174 !! *** routine mynode *** … … 167 176 !! ** Purpose : Find processor unit 168 177 !!---------------------------------------------------------------------- 169 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 170 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 171 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 172 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 173 INTEGER , INTENT(inout) :: kstop ! stop indicator 174 INTEGER, OPTIONAL , INTENT(in ) :: localComm 178 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! 179 CHARACTER(len=*) , INTENT(in ) :: ldname ! 180 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 181 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 182 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 183 INTEGER , INTENT(inout) :: kstop ! stop indicator 184 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 175 185 ! 176 186 INTEGER :: mynode, ierr, code, ji, ii, ios … … 181 191 ! 182 192 ii = 1 183 WRITE(ldtxt(ii),*) 184 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' 185 WRITE(ldtxt(ii),*) '~~~~~~ ' 193 WRITE(ldtxt(ii),*) ; ii = ii + 1 194 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 195 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 186 196 ! 187 197 … … 195 205 196 206 ! ! control print 197 WRITE(ldtxt(ii),*) ' Namelist nammpp' 198 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send; ii = ii + 1199 WRITE(ldtxt(ii),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer; ii = ii + 1207 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 208 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 209 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 200 210 201 211 #if defined key_agrif … … 214 224 215 225 IF( (jpni < 1) .OR. (jpnj < 1) )THEN 216 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ;ii = ii + 1226 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1 217 227 ELSE 218 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ;ii = ii + 1219 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ;ii = ii + 1220 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii +1228 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 229 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 230 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1 221 231 END IF 222 232 … … 237 247 SELECT CASE ( cn_mpi_send ) 238 248 CASE ( 'S' ) ! Standard mpi send (blocking) 239 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' 249 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 240 250 CASE ( 'B' ) ! Buffer mpi send (blocking) 241 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' 251 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 242 252 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 243 253 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 244 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' 254 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 245 255 l_isend = .TRUE. 246 256 CASE DEFAULT 247 WRITE(ldtxt(ii),cform_err) 248 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send 257 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 258 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 249 259 kstop = kstop + 1 250 260 END SELECT 251 261 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 252 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' 253 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' 262 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 263 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 254 264 kstop = kstop + 1 255 265 ELSE 256 266 SELECT CASE ( cn_mpi_send ) 257 267 CASE ( 'S' ) ! Standard mpi send (blocking) 258 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' 268 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 259 269 CALL mpi_init( ierr ) 260 270 CASE ( 'B' ) ! Buffer mpi send (blocking) 261 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' 271 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 262 272 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 263 273 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 264 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' 274 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 265 275 l_isend = .TRUE. 266 276 CALL mpi_init( ierr ) 267 277 CASE DEFAULT 268 WRITE(ldtxt(ii),cform_err) 269 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send 278 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 279 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 270 280 kstop = kstop + 1 271 281 END SELECT … … 289 299 ENDIF 290 300 301 #if defined key_agrif 302 IF (Agrif_Root()) THEN 303 CALL Agrif_MPI_Init(mpi_comm_opa) 304 ELSE 305 CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 306 ENDIF 307 #endif 308 291 309 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 292 310 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) … … 294 312 295 313 IF( mynode == 0 ) THEN 296 CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )297 WRITE(kumond, nammpp)314 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 315 WRITE(kumond, nammpp) 298 316 ENDIF 299 317 ! … … 301 319 ! 302 320 END FUNCTION mynode 321 303 322 304 323 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) … … 330 349 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 331 350 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 332 ! !351 ! 333 352 INTEGER :: ji, jj, jk, jl ! dummy loop indices 334 353 INTEGER :: imigr, iihom, ijhom ! temporary integers 335 354 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 336 355 REAL(wp) :: zland 337 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 338 ! 356 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 339 357 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 340 358 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 341 342 359 !!---------------------------------------------------------------------- 343 360 … … 347 364 ! 348 365 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 349 ELSE ; zland = 0. e0! zero by default366 ELSE ; zland = 0._wp ! zero by default 350 367 ENDIF 351 368 … … 438 455 END SELECT 439 456 440 441 457 ! 3. North and south directions 442 458 ! ----------------------------- … … 491 507 END SELECT 492 508 493 494 509 ! 4. north fold treatment 495 510 ! ----------------------- … … 509 524 510 525 511 SUBROUTINE mpp_lnk_2d ( pt2d, cd_type, psgn, cd_mpp, pval )512 !!---------------------------------------------------------------------- 513 !! *** routine mpp_lnk_2d ***514 !! 515 !! ** Purpose : Message passing mana dgement for 2d array526 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 527 !!---------------------------------------------------------------------- 528 !! *** routine mpp_lnk_2d_multiple *** 529 !! 530 !! ** Purpose : Message passing management for multiple 2d arrays 516 531 !! 517 532 !! ** Method : Use mppsend and mpprecv function for passing mask … … 526 541 !! noso : number for local neighboring processors 527 542 !! nono : number for local neighboring processors 543 !!---------------------------------------------------------------------- 544 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 545 ! ! = T , U , V , F , W and I points 546 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 547 ! ! = 1. , the sign is kept 548 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 549 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 550 !! 551 INTEGER :: ji, jj, jl ! dummy loop indices 552 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 553 INTEGER :: imigr, iihom, ijhom ! temporary integers 554 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 555 INTEGER :: num_fields 556 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 557 REAL(wp) :: zland 558 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 559 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 560 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 561 562 !!---------------------------------------------------------------------- 563 ! 564 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 565 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 566 ! 567 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 568 ELSE ; zland = 0._wp ! zero by default 569 ENDIF 570 571 ! 1. standard boundary treatment 572 ! ------------------------------ 573 ! 574 !First Array 575 DO ii = 1 , num_fields 576 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 577 ! 578 ! WARNING pt2d is defined only between nld and nle 579 DO jj = nlcj+1, jpj ! added line(s) (inner only) 580 pt2d_array(ii)%pt2d(nldi :nlei , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 581 pt2d_array(ii)%pt2d(1 :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi , nlej) 582 pt2d_array(ii)%pt2d(nlei+1:nlci , jj) = pt2d_array(ii)%pt2d( nlei, nlej) 583 END DO 584 DO ji = nlci+1, jpi ! added column(s) (full) 585 pt2d_array(ii)%pt2d(ji, nldj :nlej ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 586 pt2d_array(ii)%pt2d(ji, 1 :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj ) 587 pt2d_array(ii)%pt2d(ji, nlej+1:jpj ) = pt2d_array(ii)%pt2d(nlei, nlej) 588 END DO 589 ! 590 ELSE ! standard close or cyclic treatment 591 ! 592 ! ! East-West boundaries 593 IF( nbondi == 2 .AND. & ! Cyclic east-west 594 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 595 pt2d_array(ii)%pt2d( 1 , : ) = pt2d_array(ii)%pt2d( jpim1, : ) ! west 596 pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d( 2 , : ) ! east 597 ELSE ! closed 598 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( 1 : jpreci,:) = zland ! south except F-point 599 pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north 600 ENDIF 601 ! ! North-South boundaries (always closed) 602 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d(:, 1:jprecj ) = zland ! south except F-point 603 pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north 604 ! 605 ENDIF 606 END DO 607 608 ! 2. East and west directions exchange 609 ! ------------------------------------ 610 ! we play with the neigbours AND the row number because of the periodicity 611 ! 612 DO ii = 1 , num_fields 613 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 614 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 615 iihom = nlci-nreci 616 DO jl = 1, jpreci 617 zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 618 zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 619 END DO 620 END SELECT 621 END DO 622 ! 623 ! ! Migrations 624 imigr = jpreci * jpj 625 ! 626 SELECT CASE ( nbondi ) 627 CASE ( -1 ) 628 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 629 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 630 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 631 CASE ( 0 ) 632 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 633 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 634 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 635 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 636 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 637 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 638 CASE ( 1 ) 639 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 640 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 641 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 642 END SELECT 643 ! 644 ! ! Write Dirichlet lateral conditions 645 iihom = nlci - jpreci 646 ! 647 648 DO ii = 1 , num_fields 649 SELECT CASE ( nbondi ) 650 CASE ( -1 ) 651 DO jl = 1, jpreci 652 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 653 END DO 654 CASE ( 0 ) 655 DO jl = 1, jpreci 656 pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 657 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 658 END DO 659 CASE ( 1 ) 660 DO jl = 1, jpreci 661 pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 662 END DO 663 END SELECT 664 END DO 665 666 ! 3. North and south directions 667 ! ----------------------------- 668 ! always closed : we play only with the neigbours 669 ! 670 !First Array 671 DO ii = 1 , num_fields 672 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 673 ijhom = nlcj-nrecj 674 DO jl = 1, jprecj 675 zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 676 zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 677 END DO 678 ENDIF 679 END DO 680 ! 681 ! ! Migrations 682 imigr = jprecj * jpi 683 ! 684 SELECT CASE ( nbondj ) 685 CASE ( -1 ) 686 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 687 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 688 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 689 CASE ( 0 ) 690 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 691 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 692 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 693 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 694 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 695 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 696 CASE ( 1 ) 697 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 698 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 699 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 700 END SELECT 701 ! 702 ! ! Write Dirichlet lateral conditions 703 ijhom = nlcj - jprecj 704 ! 705 706 DO ii = 1 , num_fields 707 !First Array 708 SELECT CASE ( nbondj ) 709 CASE ( -1 ) 710 DO jl = 1, jprecj 711 pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 712 END DO 713 CASE ( 0 ) 714 DO jl = 1, jprecj 715 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 716 pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 717 END DO 718 CASE ( 1 ) 719 DO jl = 1, jprecj 720 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 721 END DO 722 END SELECT 723 END DO 724 725 ! 4. north fold treatment 726 ! ----------------------- 727 ! 728 DO ii = 1 , num_fields 729 !First Array 730 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 731 ! 732 SELECT CASE ( jpni ) 733 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 734 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 735 END SELECT 736 ! 737 ENDIF 738 ! 739 END DO 740 ! 741 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 742 ! 743 END SUBROUTINE mpp_lnk_2d_multiple 744 745 746 SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) 747 !!--------------------------------------------------------------------- 748 REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 749 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 750 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 751 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 752 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 753 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 754 INTEGER , INTENT (inout) :: num_fields 755 !!--------------------------------------------------------------------- 756 num_fields = num_fields + 1 757 pt2d_array(num_fields)%pt2d => pt2d 758 type_array(num_fields) = cd_type 759 psgn_array(num_fields) = psgn 760 END SUBROUTINE load_array 761 762 763 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 764 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 765 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 766 !!--------------------------------------------------------------------- 767 ! Second 2D array on which the boundary condition is applied 768 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 769 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 770 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 771 ! define the nature of ptab array grid-points 772 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 773 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 774 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 775 ! =-1 the sign change across the north fold boundary 776 REAL(wp) , INTENT(in ) :: psgnA 777 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 778 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 779 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 780 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 781 !! 782 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 783 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 784 ! ! = T , U , V , F , W and I points 785 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 786 INTEGER :: num_fields 787 !!--------------------------------------------------------------------- 788 ! 789 num_fields = 0 790 ! 791 ! Load the first array 792 CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 793 ! 794 ! Look if more arrays are added 795 IF( PRESENT(psgnB) ) CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 796 IF( PRESENT(psgnC) ) CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 797 IF( PRESENT(psgnD) ) CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 798 IF( PRESENT(psgnE) ) CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 799 IF( PRESENT(psgnF) ) CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 800 IF( PRESENT(psgnG) ) CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 801 IF( PRESENT(psgnH) ) CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 802 IF( PRESENT(psgnI) ) CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 803 ! 804 CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 805 ! 806 END SUBROUTINE mpp_lnk_2d_9 807 808 809 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 810 !!---------------------------------------------------------------------- 811 !! *** routine mpp_lnk_2d *** 812 !! 813 !! ** Purpose : Message passing manadgement for 2d array 814 !! 815 !! ** Method : Use mppsend and mpprecv function for passing mask 816 !! between processors following neighboring subdomains. 817 !! domain parameters 818 !! nlci : first dimension of the local subdomain 819 !! nlcj : second dimension of the local subdomain 820 !! nbondi : mark for "east-west local boundary" 821 !! nbondj : mark for "north-south local boundary" 822 !! noea : number for local neighboring processors 823 !! nowe : number for local neighboring processors 824 !! noso : number for local neighboring processors 825 !! nono : number for local neighboring processors 528 826 !! 529 827 !!---------------------------------------------------------------------- … … 540 838 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 541 839 REAL(wp) :: zland 542 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 543 ! 840 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 544 841 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 545 842 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 546 547 !!---------------------------------------------------------------------- 548 843 !!---------------------------------------------------------------------- 844 ! 549 845 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 550 846 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 551 552 847 ! 553 848 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 554 ELSE ; zland = 0. e0! zero by default849 ELSE ; zland = 0._wp ! zero by default 555 850 ENDIF 556 851 … … 743 1038 INTEGER :: imigr, iihom, ijhom ! temporary integers 744 1039 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 745 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 746 ! 1040 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 747 1041 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ns, zt4sn ! 2 x 3d for north-south & south-north 748 1042 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ew, zt4we ! 2 x 3d for east-west & west-east 749 750 ! !----------------------------------------------------------------------1043 !!---------------------------------------------------------------------- 1044 ! 751 1045 ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) , & 752 1046 & zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 753 754 1047 ! 755 1048 ! 1. standard boundary treatment 756 1049 ! ------------------------------ … … 1096 1389 END DO 1097 1390 END SELECT 1098 1391 ! 1099 1392 END SUBROUTINE mpp_lnk_2d_e 1100 1393 1394 SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 1395 !!---------------------------------------------------------------------- 1396 !! *** routine mpp_lnk_sum_3d *** 1397 !! 1398 !! ** Purpose : Message passing manadgement (sum the overlap region) 1399 !! 1400 !! ** Method : Use mppsend and mpprecv function for passing mask 1401 !! between processors following neighboring subdomains. 1402 !! domain parameters 1403 !! nlci : first dimension of the local subdomain 1404 !! nlcj : second dimension of the local subdomain 1405 !! nbondi : mark for "east-west local boundary" 1406 !! nbondj : mark for "north-south local boundary" 1407 !! noea : number for local neighboring processors 1408 !! nowe : number for local neighboring processors 1409 !! noso : number for local neighboring processors 1410 !! nono : number for local neighboring processors 1411 !! 1412 !! ** Action : ptab with update value at its periphery 1413 !! 1414 !!---------------------------------------------------------------------- 1415 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 1416 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1417 ! ! = T , U , V , F , W points 1418 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1419 ! ! = 1. , the sign is kept 1420 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1421 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 1422 !! 1423 INTEGER :: ji, jj, jk, jl ! dummy loop indices 1424 INTEGER :: imigr, iihom, ijhom ! temporary integers 1425 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1426 REAL(wp) :: zland 1427 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1428 ! 1429 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 1430 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 1431 1432 !!---------------------------------------------------------------------- 1433 1434 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 1435 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 1436 1437 ! 1438 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1439 ELSE ; zland = 0.e0 ! zero by default 1440 ENDIF 1441 1442 ! 1. standard boundary treatment 1443 ! ------------------------------ 1444 ! 2. East and west directions exchange 1445 ! ------------------------------------ 1446 ! we play with the neigbours AND the row number because of the periodicity 1447 ! 1448 SELECT CASE ( nbondi ) ! Read lateral conditions 1449 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1450 iihom = nlci-jpreci 1451 DO jl = 1, jpreci 1452 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0.0_wp 1453 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp 1454 END DO 1455 END SELECT 1456 ! 1457 ! ! Migrations 1458 imigr = jpreci * jpj * jpk 1459 ! 1460 SELECT CASE ( nbondi ) 1461 CASE ( -1 ) 1462 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 1463 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 1464 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1465 CASE ( 0 ) 1466 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 1467 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 1468 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 1469 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 1470 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1471 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1472 CASE ( 1 ) 1473 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 1474 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 1475 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1476 END SELECT 1477 ! 1478 ! ! Write lateral conditions 1479 iihom = nlci-nreci 1480 ! 1481 SELECT CASE ( nbondi ) 1482 CASE ( -1 ) 1483 DO jl = 1, jpreci 1484 ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2) 1485 END DO 1486 CASE ( 0 ) 1487 DO jl = 1, jpreci 1488 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 1489 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 1490 END DO 1491 CASE ( 1 ) 1492 DO jl = 1, jpreci 1493 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 1494 END DO 1495 END SELECT 1496 1497 1498 ! 3. North and south directions 1499 ! ----------------------------- 1500 ! always closed : we play only with the neigbours 1501 ! 1502 IF( nbondj /= 2 ) THEN ! Read lateral conditions 1503 ijhom = nlcj-jprecj 1504 DO jl = 1, jprecj 1505 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp 1506 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0.0_wp 1507 END DO 1508 ENDIF 1509 ! 1510 ! ! Migrations 1511 imigr = jprecj * jpi * jpk 1512 ! 1513 SELECT CASE ( nbondj ) 1514 CASE ( -1 ) 1515 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 1516 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 1517 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1518 CASE ( 0 ) 1519 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 1520 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 1521 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 1522 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 1523 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1524 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1525 CASE ( 1 ) 1526 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 1527 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 1528 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1529 END SELECT 1530 ! 1531 ! ! Write lateral conditions 1532 ijhom = nlcj-nrecj 1533 ! 1534 SELECT CASE ( nbondj ) 1535 CASE ( -1 ) 1536 DO jl = 1, jprecj 1537 ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) 1538 END DO 1539 CASE ( 0 ) 1540 DO jl = 1, jprecj 1541 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) 1542 ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) 1543 END DO 1544 CASE ( 1 ) 1545 DO jl = 1, jprecj 1546 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl ,:,2) 1547 END DO 1548 END SELECT 1549 1550 1551 ! 4. north fold treatment 1552 ! ----------------------- 1553 ! 1554 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1555 ! 1556 SELECT CASE ( jpni ) 1557 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 1558 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 1559 END SELECT 1560 ! 1561 ENDIF 1562 ! 1563 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 1564 ! 1565 END SUBROUTINE mpp_lnk_sum_3d 1566 1567 SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 1568 !!---------------------------------------------------------------------- 1569 !! *** routine mpp_lnk_sum_2d *** 1570 !! 1571 !! ** Purpose : Message passing manadgement for 2d array (sum the overlap region) 1572 !! 1573 !! ** Method : Use mppsend and mpprecv function for passing mask 1574 !! between processors following neighboring subdomains. 1575 !! domain parameters 1576 !! nlci : first dimension of the local subdomain 1577 !! nlcj : second dimension of the local subdomain 1578 !! nbondi : mark for "east-west local boundary" 1579 !! nbondj : mark for "north-south local boundary" 1580 !! noea : number for local neighboring processors 1581 !! nowe : number for local neighboring processors 1582 !! noso : number for local neighboring processors 1583 !! nono : number for local neighboring processors 1584 !! 1585 !!---------------------------------------------------------------------- 1586 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 1587 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1588 ! ! = T , U , V , F , W and I points 1589 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1590 ! ! = 1. , the sign is kept 1591 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1592 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 1593 !! 1594 INTEGER :: ji, jj, jl ! dummy loop indices 1595 INTEGER :: imigr, iihom, ijhom ! temporary integers 1596 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1597 REAL(wp) :: zland 1598 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1599 ! 1600 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 1601 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 1602 1603 !!---------------------------------------------------------------------- 1604 1605 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 1606 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 1607 1608 ! 1609 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1610 ELSE ; zland = 0.e0 ! zero by default 1611 ENDIF 1612 1613 ! 1. standard boundary treatment 1614 ! ------------------------------ 1615 ! 2. East and west directions exchange 1616 ! ------------------------------------ 1617 ! we play with the neigbours AND the row number because of the periodicity 1618 ! 1619 SELECT CASE ( nbondi ) ! Read lateral conditions 1620 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1621 iihom = nlci - jpreci 1622 DO jl = 1, jpreci 1623 zt2ew(:,jl,1) = pt2d(jl ,:) ; pt2d(jl ,:) = 0.0_wp 1624 zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp 1625 END DO 1626 END SELECT 1627 ! 1628 ! ! Migrations 1629 imigr = jpreci * jpj 1630 ! 1631 SELECT CASE ( nbondi ) 1632 CASE ( -1 ) 1633 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 1634 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 1635 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1636 CASE ( 0 ) 1637 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 1638 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 1639 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 1640 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 1641 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1642 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1643 CASE ( 1 ) 1644 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 1645 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 1646 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1647 END SELECT 1648 ! 1649 ! ! Write lateral conditions 1650 iihom = nlci-nreci 1651 ! 1652 SELECT CASE ( nbondi ) 1653 CASE ( -1 ) 1654 DO jl = 1, jpreci 1655 pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) 1656 END DO 1657 CASE ( 0 ) 1658 DO jl = 1, jpreci 1659 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 1660 pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) 1661 END DO 1662 CASE ( 1 ) 1663 DO jl = 1, jpreci 1664 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 1665 END DO 1666 END SELECT 1667 1668 1669 ! 3. North and south directions 1670 ! ----------------------------- 1671 ! always closed : we play only with the neigbours 1672 ! 1673 IF( nbondj /= 2 ) THEN ! Read lateral conditions 1674 ijhom = nlcj - jprecj 1675 DO jl = 1, jprecj 1676 zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp 1677 zt2ns(:,jl,1) = pt2d(:,jl ) ; pt2d(:,jl ) = 0.0_wp 1678 END DO 1679 ENDIF 1680 ! 1681 ! ! Migrations 1682 imigr = jprecj * jpi 1683 ! 1684 SELECT CASE ( nbondj ) 1685 CASE ( -1 ) 1686 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 1687 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 1688 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1689 CASE ( 0 ) 1690 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 1691 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 1692 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 1693 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 1694 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1695 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1696 CASE ( 1 ) 1697 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 1698 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 1699 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1700 END SELECT 1701 ! 1702 ! ! Write lateral conditions 1703 ijhom = nlcj-nrecj 1704 ! 1705 SELECT CASE ( nbondj ) 1706 CASE ( -1 ) 1707 DO jl = 1, jprecj 1708 pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) 1709 END DO 1710 CASE ( 0 ) 1711 DO jl = 1, jprecj 1712 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 1713 pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) 1714 END DO 1715 CASE ( 1 ) 1716 DO jl = 1, jprecj 1717 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 1718 END DO 1719 END SELECT 1720 1721 1722 ! 4. north fold treatment 1723 ! ----------------------- 1724 ! 1725 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1726 ! 1727 SELECT CASE ( jpni ) 1728 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp 1729 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. 1730 END SELECT 1731 ! 1732 ENDIF 1733 ! 1734 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 1735 ! 1736 END SUBROUTINE mpp_lnk_sum_2d 1101 1737 1102 1738 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) … … 1146 1782 !!---------------------------------------------------------------------- 1147 1783 ! 1148 1149 1784 ! If a specific process number has been passed to the receive call, 1150 1785 ! use that one. Default is to use mpi_any_source 1151 use_source=mpi_any_source 1152 if(present(ksource)) then 1153 use_source=ksource 1154 end if 1155 1786 use_source = mpi_any_source 1787 IF( PRESENT(ksource) ) use_source = ksource 1788 ! 1156 1789 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag ) 1157 1790 ! … … 1167 1800 !! 1168 1801 !!---------------------------------------------------------------------- 1169 REAL(wp), DIMENSION(jpi,jpj) ,INTENT(in ) :: ptab ! subdomain input array1170 INTEGER ,INTENT(in ) :: kp ! record length1802 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array 1803 INTEGER , INTENT(in ) :: kp ! record length 1171 1804 REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array 1172 1805 !! … … 1189 1822 !! 1190 1823 !!---------------------------------------------------------------------- 1191 REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio! output array1192 INTEGER :: kp 1193 REAL(wp), DIMENSION(jpi,jpj) :: ptab! subdomain array input1824 REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array 1825 INTEGER :: kp ! Tag (not used with MPI 1826 REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input 1194 1827 !! 1195 1828 INTEGER :: itaille, ierror ! temporary integer 1196 1829 !!--------------------------------------------------------------------- 1197 1830 ! 1198 itaille =jpi*jpj1831 itaille = jpi * jpj 1199 1832 ! 1200 1833 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & … … 1214 1847 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1215 1848 INTEGER , INTENT(in ), OPTIONAL :: kcom ! 1216 ! !1849 ! 1217 1850 INTEGER :: ierror, localcomm ! temporary integer 1218 1851 INTEGER, DIMENSION(kdim) :: iwork … … 1236 1869 !! 1237 1870 !!---------------------------------------------------------------------- 1238 INTEGER, INTENT(inout) :: ktab 1239 INTEGER, INTENT(in ), OPTIONAL :: kcom 1240 ! !1871 INTEGER, INTENT(inout) :: ktab ! ??? 1872 INTEGER, INTENT(in ), OPTIONAL :: kcom ! ??? 1873 ! 1241 1874 INTEGER :: ierror, iwork, localcomm ! temporary integer 1242 1875 !!---------------------------------------------------------------------- … … 1245 1878 IF( PRESENT(kcom) ) localcomm = kcom 1246 1879 ! 1247 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror )1880 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 1248 1881 ! 1249 1882 ktab = iwork … … 1259 1892 !! 1260 1893 !!---------------------------------------------------------------------- 1261 INTEGER , INTENT( in ) :: kdim 1262 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab 1263 INTEGER , INTENT( in ), OPTIONAL :: kcom 1894 INTEGER , INTENT( in ) :: kdim ! size of array 1895 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1896 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 1264 1897 !! 1265 1898 INTEGER :: ierror, localcomm ! temporary integer … … 1293 1926 IF( PRESENT(kcom) ) localcomm = kcom 1294 1927 ! 1295 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )1928 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 1296 1929 ! 1297 1930 ktab = iwork … … 1307 1940 !! 1308 1941 !!---------------------------------------------------------------------- 1309 INTEGER, INTENT(in ) :: kdim 1310 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab 1311 ! !1942 INTEGER, INTENT(in ) :: kdim ! ??? 1943 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? 1944 ! 1312 1945 INTEGER :: ierror 1313 1946 INTEGER, DIMENSION (kdim) :: iwork … … 1350 1983 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 1351 1984 INTEGER , INTENT(in ), OPTIONAL :: kcom 1352 ! !1985 ! 1353 1986 INTEGER :: ierror, localcomm 1354 1987 REAL(wp), DIMENSION(kdim) :: zwork … … 1482 2115 END SUBROUTINE mppsum_real 1483 2116 2117 1484 2118 SUBROUTINE mppsum_realdd( ytab, kcom ) 1485 2119 !!---------------------------------------------------------------------- … … 1490 2124 !! 1491 2125 !!----------------------------------------------------------------------- 1492 COMPLEX(wp), INTENT(inout) ::ytab ! input scalar1493 INTEGER , INTENT( in ), OPTIONAL ::kcom1494 1495 !! * Local variables (MPI version)1496 INTEGER :: ierror1497 INTEGER :: localcomm1498 COMPLEX(wp) :: zwork1499 2126 COMPLEX(wp), INTENT(inout) :: ytab ! input scalar 2127 INTEGER , INTENT(in ), OPTIONAL :: kcom 2128 ! 2129 INTEGER :: ierror 2130 INTEGER :: localcomm 2131 COMPLEX(wp) :: zwork 2132 !!----------------------------------------------------------------------- 2133 ! 1500 2134 localcomm = mpi_comm_opa 1501 IF( PRESENT(kcom) ) localcomm = kcom1502 2135 IF( PRESENT(kcom) ) localcomm = kcom 2136 ! 1503 2137 ! reduce local sums into global sum 1504 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, & 1505 MPI_SUMDD,localcomm,ierror) 2138 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 1506 2139 ytab = zwork 1507 2140 ! 1508 2141 END SUBROUTINE mppsum_realdd 1509 2142 … … 1517 2150 !! 1518 2151 !!----------------------------------------------------------------------- 1519 INTEGER , INTENT( in ) :: kdim ! size of ytab 1520 COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array 1521 INTEGER , INTENT( in ), OPTIONAL :: kcom 1522 1523 !! * Local variables (MPI version) 1524 INTEGER :: ierror ! temporary integer 1525 INTEGER :: localcomm 2152 INTEGER , INTENT(in ) :: kdim ! size of ytab 2153 COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array 2154 INTEGER , OPTIONAL , INTENT(in ) :: kcom 2155 ! 2156 INTEGER:: ierror, localcomm ! local integer 1526 2157 COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace 1527 2158 !!----------------------------------------------------------------------- 2159 ! 1528 2160 localcomm = mpi_comm_opa 1529 IF( PRESENT(kcom) ) localcomm = kcom 1530 1531 CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, & 1532 MPI_SUMDD,localcomm,ierror) 2161 IF( PRESENT(kcom) ) localcomm = kcom 2162 ! 2163 CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 1533 2164 ytab(:) = zwork(:) 1534 2165 ! 1535 2166 END SUBROUTINE mppsum_a_realdd 2167 1536 2168 1537 2169 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) … … 1549 2181 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 1550 2182 INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame 1551 !! 2183 ! 2184 INTEGER :: ierror 1552 2185 INTEGER , DIMENSION(2) :: ilocs 1553 INTEGER :: ierror1554 2186 REAL(wp) :: zmin ! local minimum 1555 2187 REAL(wp), DIMENSION(2,1) :: zain, zaout … … 2084 2716 IF (l_isend) THEN 2085 2717 DO jr = 1,nsndto 2086 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2718 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2719 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2720 ENDIF 2087 2721 END DO 2088 2722 ENDIF … … 2357 2991 END SUBROUTINE mpp_lbc_north_e 2358 2992 2359 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2993 2994 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2360 2995 !!---------------------------------------------------------------------- 2361 2996 !! *** routine mpp_lnk_bdy_3d *** … … 2378 3013 !! 2379 3014 !!---------------------------------------------------------------------- 2380 2381 USE lbcnfd ! north fold2382 2383 INCLUDE 'mpif.h'2384 2385 3015 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2386 3016 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points … … 2389 3019 ! ! = 1. , the sign is kept 2390 3020 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3021 ! 2391 3022 INTEGER :: ji, jj, jk, jl ! dummy loop indices 2392 INTEGER :: imigr, iihom, ijhom ! temporaryintegers3023 INTEGER :: imigr, iihom, ijhom ! local integers 2393 3024 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2394 REAL(wp) :: zland 3025 REAL(wp) :: zland ! local scalar 2395 3026 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 2396 3027 ! 2397 3028 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 2398 3029 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 2399 2400 !!---------------------------------------------------------------------- 2401 3030 !!---------------------------------------------------------------------- 3031 ! 2402 3032 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 2403 3033 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 2404 3034 2405 zland = 0. e03035 zland = 0._wp 2406 3036 2407 3037 ! 1. standard boundary treatment 2408 3038 ! ------------------------------ 2409 2410 3039 ! ! East-West boundaries 2411 3040 ! !* Cyclic east-west 2412 2413 3041 IF( nbondi == 2) THEN 2414 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN2415 ptab( 1 ,:,:) = ptab(jpim1,:,:)2416 ptab(jpi,:,:) = ptab( 2 ,:,:)2417 ELSE2418 IF( .NOT. cd_type == 'F' ) ptab( 1:jpreci,:,:) = zland ! south except F-point2419 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north2420 ENDIF3042 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 3043 ptab( 1 ,:,:) = ptab(jpim1,:,:) 3044 ptab(jpi,:,:) = ptab( 2 ,:,:) 3045 ELSE 3046 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 3047 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north 3048 ENDIF 2421 3049 ELSEIF(nbondi == -1) THEN 2422 IF( .NOT. cd_type == 'F' ) ptab( 1:jpreci,:,:) = zland ! south except F-point3050 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 2423 3051 ELSEIF(nbondi == 1) THEN 2424 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north3052 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north 2425 3053 ENDIF !* closed 2426 3054 2427 3055 IF (nbondj == 2 .OR. nbondj == -1) THEN 2428 IF( .NOT. cd_type == 'F' ) ptab(:, 1:jprecj,:) = zland ! south except F-point3056 IF( .NOT. cd_type == 'F' ) ptab(:,1:jprecj,:) = zland ! south except F-point 2429 3057 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2430 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 2431 ENDIF 2432 2433 ! 2434 3058 ptab(:,nlcj-jprecj+1:jpj,:) = zland ! north 3059 ENDIF 3060 ! 2435 3061 ! 2. East and west directions exchange 2436 3062 ! ------------------------------------ … … 2489 3115 CASE ( 0 ) 2490 3116 DO jl = 1, jpreci 2491 ptab( jl,:,:) = zt3we(:,jl,:,2)3117 ptab( jl,:,:) = zt3we(:,jl,:,2) 2492 3118 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 2493 3119 END DO 2494 3120 CASE ( 1 ) 2495 3121 DO jl = 1, jpreci 2496 ptab( jl,:,:) = zt3we(:,jl,:,2)3122 ptab( jl,:,:) = zt3we(:,jl,:,2) 2497 3123 END DO 2498 3124 END SELECT … … 2580 3206 END SUBROUTINE mpp_lnk_bdy_3d 2581 3207 2582 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 3208 3209 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 2583 3210 !!---------------------------------------------------------------------- 2584 3211 !! *** routine mpp_lnk_bdy_2d *** … … 2601 3228 !! 2602 3229 !!---------------------------------------------------------------------- 2603 2604 USE lbcnfd ! north fold 2605 2606 INCLUDE 'mpif.h' 2607 2608 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2609 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 2610 ! ! = T , U , V , F , W points 2611 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 2612 ! ! = 1. , the sign is kept 2613 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3230 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3231 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 3232 ! ! = T , U , V , F , W points 3233 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 3234 ! ! = 1. , the sign is kept 3235 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3236 ! 2614 3237 INTEGER :: ji, jj, jl ! dummy loop indices 2615 INTEGER :: imigr, iihom, ijhom ! temporaryintegers3238 INTEGER :: imigr, iihom, ijhom ! local integers 2616 3239 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2617 3240 REAL(wp) :: zland … … 2620 3243 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 2621 3244 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 2622 2623 3245 !!---------------------------------------------------------------------- 2624 3246 … … 2626 3248 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 2627 3249 2628 zland = 0. e03250 zland = 0._wp 2629 3251 2630 3252 ! 1. standard boundary treatment 2631 3253 ! ------------------------------ 2632 2633 3254 ! ! East-West boundaries 2634 ! !* Cyclic east-west 2635 2636 IF( nbondi == 2) THEN 2637 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 2638 ptab( 1 ,:) = ptab(jpim1,:) 2639 ptab(jpi,:) = ptab( 2 ,:) 2640 ELSE 2641 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2642 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 2643 ENDIF 3255 ! !* Cyclic east-west 3256 IF( nbondi == 2 ) THEN 3257 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 3258 ptab( 1 ,:) = ptab(jpim1,:) 3259 ptab(jpi,:) = ptab( 2 ,:) 3260 ELSE 3261 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3262 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3263 ENDIF 2644 3264 ELSEIF(nbondi == -1) THEN 2645 IF( .NOT. cd_type == 'F' )ptab( 1 :jpreci,:) = zland ! south except F-point3265 IF( .NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2646 3266 ELSEIF(nbondi == 1) THEN 2647 ptab(nlci-jpreci+1:jpi ,:) = zland ! north2648 ENDIF !* closed2649 2650 IF (nbondj == 2 .OR. nbondj == -1) THEN2651 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj) = zland! south except F-point3267 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3268 ENDIF 3269 ! !* closed 3270 IF( nbondj == 2 .OR. nbondj == -1 ) THEN 3271 IF( .NOT.cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point 2652 3272 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2653 ptab(:,nlcj-jprecj+1:jpj) = zland ! north 2654 ENDIF 2655 2656 ! 2657 3273 ptab(:,nlcj-jprecj+1:jpj ) = zland ! north 3274 ENDIF 3275 ! 2658 3276 ! 2. East and west directions exchange 2659 3277 ! ------------------------------------ … … 2802 3420 ! 2803 3421 END SUBROUTINE mpp_lnk_bdy_2d 3422 2804 3423 2805 3424 SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) … … 2891 3510 END SUBROUTINE DDPDD_MPI 2892 3511 3512 3513 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 3514 !!--------------------------------------------------------------------- 3515 !! *** routine mpp_lbc_north_icb *** 3516 !! 3517 !! ** Purpose : Ensure proper north fold horizontal bondary condition 3518 !! in mpp configuration in case of jpn1 > 1 and for 2d 3519 !! array with outer extra halo 3520 !! 3521 !! ** Method : North fold condition and mpp with more than one proc 3522 !! in i-direction require a specific treatment. We gather 3523 !! the 4+2*jpr2dj northern lines of the global domain on 1 3524 !! processor and apply lbc north-fold on this sub array. 3525 !! Then we scatter the north fold array back to the processors. 3526 !! This version accounts for an extra halo with icebergs. 3527 !! 3528 !!---------------------------------------------------------------------- 3529 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 3530 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 3531 ! ! = T , U , V , F or W -points 3532 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 3533 !! ! north fold, = 1. otherwise 3534 INTEGER, OPTIONAL , INTENT(in ) :: pr2dj 3535 ! 3536 INTEGER :: ji, jj, jr 3537 INTEGER :: ierr, itaille, ildi, ilei, iilb 3538 INTEGER :: ijpj, ij, iproc, ipr2dj 3539 ! 3540 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 3541 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 3542 !!---------------------------------------------------------------------- 3543 ! 3544 ijpj=4 3545 IF( PRESENT(pr2dj) ) THEN ! use of additional halos 3546 ipr2dj = pr2dj 3547 ELSE 3548 ipr2dj = 0 3549 ENDIF 3550 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 3551 ! 3552 ztab_e(:,:) = 0._wp 3553 ! 3554 ij = 0 3555 ! put in znorthloc_e the last 4 jlines of pt2d 3556 DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj 3557 ij = ij + 1 3558 DO ji = 1, jpi 3559 znorthloc_e(ji,ij)=pt2d(ji,jj) 3560 END DO 3561 END DO 3562 ! 3563 itaille = jpi * ( ijpj + 2 * ipr2dj ) 3564 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 3565 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 3566 ! 3567 DO jr = 1, ndim_rank_north ! recover the global north array 3568 iproc = nrank_north(jr) + 1 3569 ildi = nldit (iproc) 3570 ilei = nleit (iproc) 3571 iilb = nimppt(iproc) 3572 DO jj = 1, ijpj+2*ipr2dj 3573 DO ji = ildi, ilei 3574 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 3575 END DO 3576 END DO 3577 END DO 3578 3579 3580 ! 2. North-Fold boundary conditions 3581 ! ---------------------------------- 3582 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 3583 3584 ij = ipr2dj 3585 !! Scatter back to pt2d 3586 DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj 3587 ij = ij +1 3588 DO ji= 1, nlci 3589 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 3590 END DO 3591 END DO 3592 ! 3593 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 3594 ! 3595 END SUBROUTINE mpp_lbc_north_icb 3596 3597 3598 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) 3599 !!---------------------------------------------------------------------- 3600 !! *** routine mpp_lnk_2d_icb *** 3601 !! 3602 !! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs) 3603 !! 3604 !! ** Method : Use mppsend and mpprecv function for passing mask 3605 !! between processors following neighboring subdomains. 3606 !! domain parameters 3607 !! nlci : first dimension of the local subdomain 3608 !! nlcj : second dimension of the local subdomain 3609 !! jpri : number of rows for extra outer halo 3610 !! jprj : number of columns for extra outer halo 3611 !! nbondi : mark for "east-west local boundary" 3612 !! nbondj : mark for "north-south local boundary" 3613 !! noea : number for local neighboring processors 3614 !! nowe : number for local neighboring processors 3615 !! noso : number for local neighboring processors 3616 !! nono : number for local neighboring processors 3617 !!---------------------------------------------------------------------- 3618 INTEGER , INTENT(in ) :: jpri 3619 INTEGER , INTENT(in ) :: jprj 3620 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 3621 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3622 ! ! = T , U , V , F , W and I points 3623 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the 3624 !! ! north boundary, = 1. otherwise 3625 INTEGER :: jl ! dummy loop indices 3626 INTEGER :: imigr, iihom, ijhom ! temporary integers 3627 INTEGER :: ipreci, iprecj ! temporary integers 3628 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3629 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3630 !! 3631 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 3632 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 3633 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 3634 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 3635 !!---------------------------------------------------------------------- 3636 3637 ipreci = jpreci + jpri ! take into account outer extra 2D overlap area 3638 iprecj = jprecj + jprj 3639 3640 3641 ! 1. standard boundary treatment 3642 ! ------------------------------ 3643 ! Order matters Here !!!! 3644 ! 3645 ! ! East-West boundaries 3646 ! !* Cyclic east-west 3647 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 3648 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 3649 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 3650 ! 3651 ELSE !* closed 3652 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point 3653 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north 3654 ENDIF 3655 ! 3656 3657 ! north fold treatment 3658 ! ----------------------- 3659 IF( npolj /= 0 ) THEN 3660 ! 3661 SELECT CASE ( jpni ) 3662 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 3663 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj ) 3664 END SELECT 3665 ! 3666 ENDIF 3667 3668 ! 2. East and west directions exchange 3669 ! ------------------------------------ 3670 ! we play with the neigbours AND the row number because of the periodicity 3671 ! 3672 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 3673 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 3674 iihom = nlci-nreci-jpri 3675 DO jl = 1, ipreci 3676 r2dew(:,jl,1) = pt2d(jpreci+jl,:) 3677 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 3678 END DO 3679 END SELECT 3680 ! 3681 ! ! Migrations 3682 imigr = ipreci * ( jpj + 2*jprj) 3683 ! 3684 SELECT CASE ( nbondi ) 3685 CASE ( -1 ) 3686 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) 3687 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 3688 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3689 CASE ( 0 ) 3690 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 3691 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) 3692 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 3693 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 3694 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3695 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 3696 CASE ( 1 ) 3697 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 3698 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 3699 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3700 END SELECT 3701 ! 3702 ! ! Write Dirichlet lateral conditions 3703 iihom = nlci - jpreci 3704 ! 3705 SELECT CASE ( nbondi ) 3706 CASE ( -1 ) 3707 DO jl = 1, ipreci 3708 pt2d(iihom+jl,:) = r2dew(:,jl,2) 3709 END DO 3710 CASE ( 0 ) 3711 DO jl = 1, ipreci 3712 pt2d(jl-jpri,:) = r2dwe(:,jl,2) 3713 pt2d( iihom+jl,:) = r2dew(:,jl,2) 3714 END DO 3715 CASE ( 1 ) 3716 DO jl = 1, ipreci 3717 pt2d(jl-jpri,:) = r2dwe(:,jl,2) 3718 END DO 3719 END SELECT 3720 3721 3722 ! 3. North and south directions 3723 ! ----------------------------- 3724 ! always closed : we play only with the neigbours 3725 ! 3726 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 3727 ijhom = nlcj-nrecj-jprj 3728 DO jl = 1, iprecj 3729 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 3730 r2dns(:,jl,1) = pt2d(:,jprecj+jl) 3731 END DO 3732 ENDIF 3733 ! 3734 ! ! Migrations 3735 imigr = iprecj * ( jpi + 2*jpri ) 3736 ! 3737 SELECT CASE ( nbondj ) 3738 CASE ( -1 ) 3739 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) 3740 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 3741 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3742 CASE ( 0 ) 3743 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 3744 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) 3745 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 3746 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 3747 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3748 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 3749 CASE ( 1 ) 3750 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 3751 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 3752 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3753 END SELECT 3754 ! 3755 ! ! Write Dirichlet lateral conditions 3756 ijhom = nlcj - jprecj 3757 ! 3758 SELECT CASE ( nbondj ) 3759 CASE ( -1 ) 3760 DO jl = 1, iprecj 3761 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 3762 END DO 3763 CASE ( 0 ) 3764 DO jl = 1, iprecj 3765 pt2d(:,jl-jprj) = r2dsn(:,jl,2) 3766 pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 3767 END DO 3768 CASE ( 1 ) 3769 DO jl = 1, iprecj 3770 pt2d(:,jl-jprj) = r2dsn(:,jl,2) 3771 END DO 3772 END SELECT 3773 3774 END SUBROUTINE mpp_lnk_2d_icb 3775 2893 3776 #else 2894 3777 !!---------------------------------------------------------------------- … … 2916 3799 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 2917 3800 INTEGER :: ncomm_ice 3801 INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator 2918 3802 !!---------------------------------------------------------------------- 2919 3803 CONTAINS … … 2924 3808 END FUNCTION lib_mpp_alloc 2925 3809 2926 FUNCTION mynode( ldtxt, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value)3810 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 2927 3811 INTEGER, OPTIONAL , INTENT(in ) :: localComm 2928 3812 CHARACTER(len=*),DIMENSION(:) :: ldtxt 3813 CHARACTER(len=*) :: ldname 2929 3814 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 2930 IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) ) function_value = 0 3815 IF( PRESENT( localComm ) ) mpi_comm_opa = localComm 3816 function_value = 0 2931 3817 IF( .FALSE. ) ldtxt(:) = 'never done' 2932 CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )3818 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 2933 3819 END FUNCTION mynode 2934 3820 … … 3173 4059 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 3174 4060 INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number 3175 ! !4061 ! 3176 4062 CHARACTER(len=80) :: clfile 3177 4063 INTEGER :: iost 3178 4064 !!---------------------------------------------------------------------- 3179 4065 ! 3180 4066 ! adapt filename 3181 4067 ! ---------------- … … 3190 4076 knum=get_unit() 3191 4077 #endif 3192 4078 ! 3193 4079 iost=0 3194 4080 IF( cdacce(1:6) == 'DIRECT' ) THEN … … 3223 4109 STOP 'ctl_opn bad opening' 3224 4110 ENDIF 3225 4111 ! 3226 4112 END SUBROUTINE ctl_opn 3227 4113 4114 3228 4115 SUBROUTINE ctl_nam ( kios, cdnam, ldwp ) 3229 4116 !!---------------------------------------------------------------------- … … 3234 4121 !! ** Method : Fortan open 3235 4122 !!---------------------------------------------------------------------- 3236 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 3237 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs 3238 CHARACTER(len=4) :: clios ! string to convert iostat in character for print 3239 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 3240 !!---------------------------------------------------------------------- 3241 3242 ! 3243 ! ---------------- 3244 WRITE (clios, '(I4.0)') kios 4123 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 4124 CHARACTER(len=*), INTENT(in ) :: cdnam ! group name of namelist for which error occurs 4125 CHARACTER(len=4) :: clios ! string to convert iostat in character for print 4126 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 4127 !!---------------------------------------------------------------------- 4128 ! 4129 WRITE (clios, '(I4.0)') kios 3245 4130 IF( kios < 0 ) THEN 3246 CALL ctl_warn( ' W A R N I N G: end of record or file while reading namelist '&3247 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )3248 ENDIF 3249 4131 CALL ctl_warn( 'end of record or file while reading namelist ' & 4132 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) ) 4133 ENDIF 4134 ! 3250 4135 IF( kios > 0 ) THEN 3251 CALL ctl_stop( ' E R R O R : misspelled variable in namelist '&3252 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )4136 CALL ctl_stop( 'misspelled variable in namelist ' & 4137 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) ) 3253 4138 ENDIF 3254 4139 kios = 0 3255 4140 RETURN 3256 4141 ! 3257 4142 END SUBROUTINE ctl_nam 4143 3258 4144 3259 4145 INTEGER FUNCTION get_unit()
Note: See TracChangeset
for help on using the changeset viewer.
