- Timestamp:
- 2017-06-19T11:25:07+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r8170 r8186 19 19 !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl 20 20 !! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager 21 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d', 22 !! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 23 !! the mppobc routine to optimize the BDY and OBC communications 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 21 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm. 22 !! 3.5 ! 2013 (C. Ethe, G. Madec) message passing arrays as local variables 25 23 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 24 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max 27 25 !! 4.0 ! 2017 (G. Madec) automatique allocation of array argument (use any 3rd dimension) 26 !! - ! 2017 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 28 27 !!---------------------------------------------------------------------- 29 28 … … 42 41 !! mynode : indentify the processor unit 43 42 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 44 !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays45 43 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 46 44 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) … … 57 55 !! mppstop : 58 56 !! mpp_ini_north : initialisation of north fold 59 !! mpp_lbc_north : north fold processors gathering57 !!gm !! mpp_lbc_north : north fold processors gathering 60 58 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 61 59 !! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs … … 68 66 IMPLICIT NONE 69 67 PRIVATE 70 68 69 INTERFACE mpp_nfd 70 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 71 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 72 END INTERFACE 73 74 ! Interface associated to the mpp_lnk_... routines is defined in lbclnk 75 PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 76 PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 77 PUBLIC mpp_lnk_2d_e 78 ! 79 !!gm this should be useless 80 PUBLIC mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 81 PUBLIC mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 82 !!gm end 83 ! 71 84 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 72 85 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 73 PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 86 PUBLIC mpp_ini_north, mpp_lbc_north_e 87 !!gm PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 88 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 74 89 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 75 90 PUBLIC mpp_max_multiple 76 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 77 PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple 78 PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 91 !!gm PUBLIC mpp_lnk_2d_9 92 !!gm PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 79 93 PUBLIC mppscatter, mppgather 80 94 PUBLIC mpp_ini_ice, mpp_ini_znl … … 82 96 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 83 97 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 84 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb85 98 PUBLIC mpprank 86 87 TYPE arrayptr88 REAL(wp), DIMENSION (:,:), POINTER :: pt2d89 END TYPE arrayptr90 !91 PUBLIC arrayptr92 99 93 100 !! * Interfaces … … 105 112 & mppsum_realdd, mppsum_a_realdd 106 113 END INTERFACE 107 INTERFACE mpp_lbc_north108 MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d109 END INTERFACE114 !!gm INTERFACE mpp_lbc_north 115 !!gm MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 116 !!gm END INTERFACE 110 117 INTERFACE mpp_minloc 111 118 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d … … 327 334 END FUNCTION mynode 328 335 329 330 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 331 !!---------------------------------------------------------------------- 332 !! *** routine mpp_lnk_3d *** 333 !! 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 544 !! 545 !! ** Method : Use mppsend and mpprecv function for passing mask 546 !! between processors following neighboring subdomains. 547 !! domain parameters 548 !! nlci : first dimension of the local subdomain 549 !! nlcj : second dimension of the local subdomain 550 !! nbondi : mark for "east-west local boundary" 551 !! nbondj : mark for "north-south local boundary" 552 !! noea : number for local neighboring processors 553 !! nowe : number for local neighboring processors 554 !! noso : number for local neighboring processors 555 !! nono : number for local neighboring processors 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 565 INTEGER :: imigr, iihom, ijhom ! temporary integers 566 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 567 REAL(wp) :: zland 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) ) 575 ! 576 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 577 ELSE ; zland = 0._wp ! zero by default 578 ENDIF 579 580 ! 1. standard boundary treatment 581 ! ------------------------------ 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 588 DO jj = nlcj+1, jpj ! added line(s) (inner only) 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) 592 END DO 593 DO ji = nlci+1, jpi ! added column(s) (full) 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) 597 END DO 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 619 ENDIF 620 END DO 621 622 ! 2. East and west directions exchange 623 ! ------------------------------------ 624 ! we play with the neigbours AND the row number because of the periodicity 625 ! 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 636 ! 637 ! ! Migrations 638 imigr = jpreci * jpj 639 ! 640 SELECT CASE ( nbondi ) 641 CASE ( -1 ) 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) 656 END SELECT 657 ! 658 ! ! Write Dirichlet lateral conditions 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 680 ! 3. North and south directions 681 ! ----------------------------- 682 ! always closed : we play only with the neigbours 683 ! 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 694 ! 695 ! ! Migrations 696 imigr = jprecj * jpi 697 ! 698 SELECT CASE ( nbondj ) 699 CASE ( -1 ) 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) 714 END SELECT 715 ! 716 ! ! Write Dirichlet lateral conditions 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 737 ! 4. north fold treatment 738 ! ----------------------- 739 ! 740 IF( npolj /= 0 .AND. .NOT.PRESENT(cd_mpp) ) THEN 741 ! 742 SELECT CASE ( jpni ) 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. 749 END SELECT 750 ! 751 ENDIF 752 ! 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 pt2d 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 336 !!---------------------------------------------------------------------- 337 !! *** routine mpp_lnk_(2,3,4)d *** 338 !! 339 !! * Argument : dummy argument use in mpp_lnk_... routines 340 !! ptab : array or pointer of arrays on which the boundary condition is applied 341 !! cd_nat : nature of array grid-points 342 !! psgn : sign used across the north fold boundary 343 !! kfld : optional, number of pt3d arrays 344 !! cd_mpp : optional, fill the overlap area only 345 !! pval : optional, background value (used at closed boundaries) 346 !!---------------------------------------------------------------------- 347 ! 348 ! !== 2D array and array of 2D pointer ==! 349 ! 350 # define DIM_2d 351 # define ROUTINE_LNK mpp_lnk_2d 352 # include "mpp_lnk_generic.h90" 353 # undef ROUTINE_LNK 354 # define MULTI 355 # define ROUTINE_LNK mpp_lnk_2d_ptr 356 # include "mpp_lnk_generic.h90" 357 # undef ROUTINE_LNK 358 # undef MULTI 359 # undef DIM_2d 360 ! 361 ! !== 3D array and array of 3D pointer ==! 362 ! 363 # define DIM_3d 364 # define ROUTINE_LNK mpp_lnk_3d 365 # include "mpp_lnk_generic.h90" 366 # undef ROUTINE_LNK 367 # define MULTI 368 # define ROUTINE_LNK mpp_lnk_3d_ptr 369 # include "mpp_lnk_generic.h90" 370 # undef ROUTINE_LNK 371 # undef MULTI 372 # undef DIM_3d 373 ! 374 ! !== 4D array and array of 4D pointer ==! 375 ! 376 # define DIM_4d 377 # define ROUTINE_LNK mpp_lnk_4d 378 # include "mpp_lnk_generic.h90" 379 # undef ROUTINE_LNK 380 # define MULTI 381 # define ROUTINE_LNK mpp_lnk_4d_ptr 382 # include "mpp_lnk_generic.h90" 383 # undef ROUTINE_LNK 384 # undef MULTI 385 # undef DIM_4d 386 387 !!---------------------------------------------------------------------- 388 !! *** routine mpp_nfd_(2,3,4)d *** 389 !! 390 !! * Argument : dummy argument use in mpp_nfd_... routines 391 !! ptab : array or pointer of arrays on which the boundary condition is applied 392 !! cd_nat : nature of array grid-points 393 !! psgn : sign used across the north fold boundary 394 !! kfld : optional, number of pt3d arrays 395 !! cd_mpp : optional, fill the overlap area only 396 !! pval : optional, background value (used at closed boundaries) 397 !!---------------------------------------------------------------------- 398 ! 399 ! !== 2D array and array of 2D pointer ==! 400 ! 401 # define DIM_2d 402 # define ROUTINE_NFD mpp_nfd_2d 403 # include "mpp_nfd_generic.h90" 404 # undef ROUTINE_NFD 405 # define MULTI 406 # define ROUTINE_NFD mpp_nfd_2d_ptr 407 # include "mpp_nfd_generic.h90" 408 # undef ROUTINE_NFD 409 # undef MULTI 410 # undef DIM_2d 411 ! 412 ! !== 3D array and array of 3D pointer ==! 413 ! 414 # define DIM_3d 415 # define ROUTINE_NFD mpp_nfd_3d 416 # include "mpp_nfd_generic.h90" 417 # undef ROUTINE_NFD 418 # define MULTI 419 # define ROUTINE_NFD mpp_nfd_3d_ptr 420 # include "mpp_nfd_generic.h90" 421 # undef ROUTINE_NFD 422 # undef MULTI 423 # undef DIM_3d 424 ! 425 ! !== 4D array and array of 4D pointer ==! 426 ! 427 # define DIM_4d 428 # define ROUTINE_NFD mpp_nfd_4d 429 # include "mpp_nfd_generic.h90" 430 # undef ROUTINE_NFD 431 # define MULTI 432 # define ROUTINE_NFD mpp_nfd_4d_ptr 433 # include "mpp_nfd_generic.h90" 434 # undef ROUTINE_NFD 435 # undef MULTI 436 # undef DIM_4d 437 438 439 !!---------------------------------------------------------------------- 440 !! *** routine mpp_lnk_bdy_(2,3,4)d *** 441 !! 442 !! * Argument : dummy argument use in mpp_lnk_... routines 443 !! ptab : array or pointer of arrays on which the boundary condition is applied 444 !! cd_nat : nature of array grid-points 445 !! psgn : sign used across the north fold boundary 446 !! kb_bdy : BDY boundary set 447 !! kfld : optional, number of pt3d arrays 448 !!---------------------------------------------------------------------- 449 ! 450 ! !== 2D array and array of 2D pointer ==! 451 ! 452 # define DIM_2d 453 # define ROUTINE_BDY mpp_lnk_bdy_2d 454 # include "mpp_bdy_generic.h90" 455 # undef ROUTINE_BDY 456 # define MULTI 457 # define ROUTINE_BDY mpp_lnk_bdy_2d_ptr 458 # include "mpp_bdy_generic.h90" 459 # undef ROUTINE_BDY 460 # undef MULTI 461 # undef DIM_2d 462 ! 463 ! !== 3D array and array of 3D pointer ==! 464 ! 465 # define DIM_3d 466 # define ROUTINE_BDY mpp_lnk_bdy_3d 467 # include "mpp_bdy_generic.h90" 468 # undef ROUTINE_BDY 469 # define MULTI 470 # define ROUTINE_BDY mpp_lnk_bdy_3d_ptr 471 # include "mpp_bdy_generic.h90" 472 # undef ROUTINE_BDY 473 # undef MULTI 474 # undef DIM_3d 475 ! 476 ! !== 4D array and array of 4D pointer ==! 477 ! 478 !!# define DIM_4d 479 !!# define ROUTINE_BDY mpp_lnk_bdy_4d 480 !!# include "mpp_bdy_generic.h90" 481 !!# undef ROUTINE_BDY 482 !!# define MULTI 483 !!# define ROUTINE_BDY mpp_lnk_bdy_4d_ptr 484 !!# include "mpp_bdy_generic.h90" 485 !!# undef ROUTINE_BDY 486 !!# undef MULTI 487 !!# undef DIM_4d 488 489 !!---------------------------------------------------------------------- 490 !! 491 !! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D 775 492 776 493 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 pt2d 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 824 !! 825 !! ** Method : Use mppsend and mpprecv function for passing mask 826 !! between processors following neighboring subdomains. 827 !! domain parameters 828 !! nlci : first dimension of the local subdomain 829 !! nlcj : second dimension of the local subdomain 830 !! nbondi : mark for "east-west local boundary" 831 !! nbondj : mark for "north-south local boundary" 832 !! noea : number for local neighboring processors 833 !! nowe : number for local neighboring processors 834 !! noso : number for local neighboring processors 835 !! nono : number for local neighboring processors 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 pt2d 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) 843 !! 844 INTEGER :: ji, jj, jl ! dummy loop indices 845 INTEGER :: imigr, iihom, ijhom ! temporary integers 846 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 847 REAL(wp) :: zland 848 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 849 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 850 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 851 !!---------------------------------------------------------------------- 852 ! 853 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 854 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 855 ! 856 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 857 ELSE ; zland = 0._wp ! zero by default 858 ENDIF 859 860 ! 1. standard boundary treatment 861 ! ------------------------------ 862 ! 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 898 899 ! 2. East and west directions exchange 900 ! ------------------------------------ 901 ! we play with the neigbours AND the row number because of the periodicity 902 ! 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 911 ! 912 ! ! Migrations 913 imigr = jpreci * jpj 914 ! 915 SELECT CASE ( nbondi ) 916 CASE ( -1 ) 917 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 918 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 919 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 920 CASE ( 0 ) 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 ) 925 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 926 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 927 CASE ( 1 ) 928 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 929 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 930 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 931 END SELECT 932 ! 933 ! ! Write Dirichlet lateral conditions 934 iihom = nlci - jpreci 935 ! 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 952 ! 3. North and south directions 953 ! ----------------------------- 954 ! always closed : we play only with the neigbours 955 ! 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 963 ! 964 ! ! Migrations 965 imigr = jprecj * jpi 966 ! 967 SELECT CASE ( nbondj ) 968 CASE ( -1 ) 969 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 970 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 971 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 972 CASE ( 0 ) 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 ) 977 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 978 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 979 CASE ( 1 ) 980 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 981 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 982 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 983 END SELECT 984 ! 985 ! ! Write Dirichlet lateral conditions 986 ijhom = nlcj - jprecj 987 ! 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 1004 ! 4. north fold treatment 1005 ! ----------------------- 1006 ! 1007 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1008 ! 1009 SELECT CASE ( jpni ) 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. 1012 END SELECT 1013 ! 1014 ENDIF 1015 ! 1016 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 1017 ! 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 1026 !! 1027 !! ** Method : Use mppsend and mpprecv function for passing mask 1028 !! between processors following neighboring subdomains. 1029 !! domain parameters 1030 !! nlci : first dimension of the local subdomain 1031 !! nlcj : second dimension of the local subdomain 1032 !! nbondi : mark for "east-west local boundary" 1033 !! nbondj : mark for "north-south local boundary" 1034 !! noea : number for local neighboring processors 1035 !! nowe : number for local neighboring processors 1036 !! noso : number for local neighboring processors 1037 !! nono : number for local neighboring processors 1038 !! 1039 !! ** Action : ptab1 and ptab2 with update value at its periphery 1040 !! 1041 !!---------------------------------------------------------------------- 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 1050 INTEGER :: imigr, iihom, ijhom ! temporary integers 1051 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1052 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1053 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ns, zt4sn ! 2 x 3d for north-south & south-north 1054 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ew, zt4we ! 2 x 3d for east-west & west-east 1055 !!---------------------------------------------------------------------- 1056 ! 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 1062 ! 1. standard boundary treatment 1063 ! ------------------------------ 1064 ! ! East-West boundaries 1065 ! !* Cyclic 1066 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1067 ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 1068 ptab1(jpi,:,:) = ptab1( 2 ,:,:) 1069 ptab2( 1 ,:,:) = ptab2(jpim1,:,:) 1070 ptab2(jpi,:,:) = ptab2( 2 ,:,:) 1071 ELSE !* closed 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 , :) 1084 ELSE 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 1091 1092 ! 2. East and west directions exchange 1093 ! ------------------------------------ 1094 ! we play with the neigbours AND the row number because of the periodicity 1095 ! 1096 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 1097 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1098 iihom = nlci-nreci 1099 DO jl = 1, jpreci 1100 zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 1101 zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 1102 zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 1103 zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 1104 END DO 1105 END SELECT 1106 ! 1107 ! ! Migrations 1108 imigr = jpreci * jpj * ipk *2 1109 ! 1110 SELECT CASE ( nbondi ) 1111 CASE ( -1 ) 1112 CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 ) 1113 CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 1114 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1115 CASE ( 0 ) 1116 CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1117 CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 ) 1118 CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 1119 CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 1120 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1121 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1122 CASE ( 1 ) 1123 CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1124 CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 1125 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1126 END SELECT 1127 ! 1128 ! ! Write Dirichlet lateral conditions 1129 iihom = nlci - jpreci 1130 ! 1131 SELECT CASE ( nbondi ) 1132 CASE ( -1 ) 1133 DO jl = 1, jpreci 1134 ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 1135 ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 1136 END DO 1137 CASE ( 0 ) 1138 DO jl = 1, jpreci 1139 ptab1(jl ,:,:) = zt4we(:,jl,:,1,2) 1140 ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 1141 ptab2(jl ,:,:) = zt4we(:,jl,:,2,2) 1142 ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 1143 END DO 1144 CASE ( 1 ) 1145 DO jl = 1, jpreci 1146 ptab1(jl ,:,:) = zt4we(:,jl,:,1,2) 1147 ptab2(jl ,:,:) = zt4we(:,jl,:,2,2) 1148 END DO 1149 END SELECT 1150 1151 ! 3. North and south directions 1152 ! ----------------------------- 1153 ! always closed : we play only with the neigbours 1154 ! 1155 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1156 ijhom = nlcj - nrecj 1157 DO jl = 1, jprecj 1158 zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 1159 zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 1160 zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 1161 zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 1162 END DO 1163 ENDIF 1164 ! 1165 ! ! Migrations 1166 imigr = jprecj * jpi * ipk * 2 1167 ! 1168 SELECT CASE ( nbondj ) 1169 CASE ( -1 ) 1170 CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 1171 CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 1172 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1173 CASE ( 0 ) 1174 CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1175 CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 1176 CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 1177 CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 1178 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1179 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1180 CASE ( 1 ) 1181 CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1182 CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 1183 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1184 END SELECT 1185 ! 1186 ! ! Write Dirichlet lateral conditions 1187 ijhom = nlcj - jprecj 1188 ! 1189 SELECT CASE ( nbondj ) 1190 CASE ( -1 ) 1191 DO jl = 1, jprecj 1192 ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 1193 ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 1194 END DO 1195 CASE ( 0 ) 1196 DO jl = 1, jprecj 1197 ptab1(:,jl ,:) = zt4sn(:,jl,:,1,2) 1198 ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 1199 ptab2(:,jl ,:) = zt4sn(:,jl,:,2,2) 1200 ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 1201 END DO 1202 CASE ( 1 ) 1203 DO jl = 1, jprecj 1204 ptab1(:,jl,:) = zt4sn(:,jl,:,1,2) 1205 ptab2(:,jl,:) = zt4sn(:,jl,:,2,2) 1206 END DO 1207 END SELECT 1208 1209 ! 4. north fold treatment 1210 ! ----------------------- 1211 IF( npolj /= 0 ) THEN 1212 ! 1213 SELECT CASE ( jpni ) 1214 CASE ( 1 ) 1215 CALL lbc_nfd ( ptab1, cd_type1, psgn ) ! only for northern procs. 1216 CALL lbc_nfd ( ptab2, cd_type2, psgn ) 1217 CASE DEFAULT 1218 CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs. 1219 CALL mpp_lbc_north (ptab2, cd_type2, psgn) 1220 END SELECT 1221 ! 1222 ENDIF 1223 ! 1224 DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we ) 1225 ! 1226 END SUBROUTINE mpp_lnk_3d_gather 494 !! mpp_lnk_2d_e utilisé dans ICB 495 496 497 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 498 499 500 !!---------------------------------------------------------------------- 1227 501 1228 502 … … 1297 571 ! 1298 572 SELECT CASE ( jpni ) 1299 1300 CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )573 !!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 574 !!gm ERROR CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn ) 1301 575 END SELECT 1302 576 ! … … 1411 685 1412 686 1413 SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval )1414 !!----------------------------------------------------------------------1415 !! *** routine mpp_lnk_sum_3d ***1416 !!1417 !! ** Purpose : Message passing manadgement (sum the overlap region)1418 !!1419 !! ** Method : Use mppsend and mpprecv function for passing mask1420 !! between processors following neighboring subdomains.1421 !! domain parameters1422 !! nlci : first dimension of the local subdomain1423 !! nlcj : second dimension of the local subdomain1424 !! nbondi : mark for "east-west local boundary"1425 !! nbondj : mark for "north-south local boundary"1426 !! noea : number for local neighboring processors1427 !! nowe : number for local neighboring processors1428 !! noso : number for local neighboring processors1429 !! nono : number for local neighboring processors1430 !!1431 !! ** Action : ptab with update value at its periphery1432 !!1433 !!----------------------------------------------------------------------1434 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied1435 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1436 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary1437 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only1438 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)1439 !1440 INTEGER :: ji, jj, jk, jl ! dummy loop indices1441 INTEGER :: imigr, iihom, ijhom ! temporary integers1442 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1443 REAL(wp) :: zland1444 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1445 !1446 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north1447 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east1448 !!----------------------------------------------------------------------1449 !1450 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), &1451 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) )1452 !1453 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value1454 ELSE ; zland = 0._wp ! zero by default1455 ENDIF1456 1457 ! 1. standard boundary treatment1458 ! ------------------------------1459 ! 2. East and west directions exchange1460 ! ------------------------------------1461 ! we play with the neigbours AND the row number because of the periodicity1462 !1463 SELECT CASE ( nbondi ) ! Read lateral conditions1464 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1465 iihom = nlci-jpreci1466 DO jl = 1, jpreci1467 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0._wp1468 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0._wp1469 END DO1470 END SELECT1471 !1472 ! ! Migrations1473 imigr = jpreci * jpj * jpk1474 !1475 SELECT CASE ( nbondi )1476 CASE ( -1 )1477 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )1478 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )1479 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1480 CASE ( 0 )1481 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )1482 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )1483 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )1484 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )1485 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1486 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)1487 CASE ( 1 )1488 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )1489 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )1490 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1491 END SELECT1492 !1493 ! ! Write lateral conditions1494 iihom = nlci-nreci1495 !1496 SELECT CASE ( nbondi )1497 CASE ( -1 )1498 DO jl = 1, jpreci1499 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2)1500 END DO1501 CASE ( 0 )1502 DO jl = 1, jpreci1503 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2)1504 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2)1505 END DO1506 CASE ( 1 )1507 DO jl = 1, jpreci1508 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2)1509 END DO1510 END SELECT1511 1512 ! 3. North and south directions1513 ! -----------------------------1514 ! always closed : we play only with the neigbours1515 !1516 IF( nbondj /= 2 ) THEN ! Read lateral conditions1517 ijhom = nlcj-jprecj1518 DO jl = 1, jprecj1519 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0._wp1520 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0._wp1521 END DO1522 ENDIF1523 !1524 ! ! Migrations1525 imigr = jprecj * jpi * jpk1526 !1527 SELECT CASE ( nbondj )1528 CASE ( -1 )1529 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )1530 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )1531 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1532 CASE ( 0 )1533 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )1534 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )1535 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )1536 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )1537 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1538 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)1539 CASE ( 1 )1540 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )1541 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )1542 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1543 END SELECT1544 !1545 ! ! Write lateral conditions1546 ijhom = nlcj-nrecj1547 !1548 SELECT CASE ( nbondj )1549 CASE ( -1 )1550 DO jl = 1, jprecj1551 ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2)1552 END DO1553 CASE ( 0 )1554 DO jl = 1, jprecj1555 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2)1556 ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2)1557 END DO1558 CASE ( 1 )1559 DO jl = 1, jprecj1560 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl ,:,2)1561 END DO1562 END SELECT1563 1564 ! 4. north fold treatment1565 ! -----------------------1566 !1567 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN1568 !1569 SELECT CASE ( jpni )1570 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp1571 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.1572 END SELECT1573 !1574 ENDIF1575 !1576 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )1577 !1578 END SUBROUTINE mpp_lnk_sum_3d1579 1580 1581 SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval )1582 !!----------------------------------------------------------------------1583 !! *** routine mpp_lnk_sum_2d ***1584 !!1585 !! ** Purpose : Message passing manadgement for 2d array (sum the overlap region)1586 !!1587 !! ** Method : Use mppsend and mpprecv function for passing mask1588 !! between processors following neighboring subdomains.1589 !! domain parameters1590 !! nlci : first dimension of the local subdomain1591 !! nlcj : second dimension of the local subdomain1592 !! nbondi : mark for "east-west local boundary"1593 !! nbondj : mark for "north-south local boundary"1594 !! noea : number for local neighboring processors1595 !! nowe : number for local neighboring processors1596 !! noso : number for local neighboring processors1597 !! nono : number for local neighboring processors1598 !!----------------------------------------------------------------------1599 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied1600 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points1601 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary1602 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only1603 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)1604 !!1605 INTEGER :: ji, jj, jl ! dummy loop indices1606 INTEGER :: imigr, iihom, ijhom ! temporary integers1607 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1608 REAL(wp) :: zland1609 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1610 !1611 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north1612 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east1613 !!----------------------------------------------------------------------1614 !1615 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &1616 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )1617 !1618 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value1619 ELSE ; zland = 0._wp ! zero by default1620 ENDIF1621 1622 ! 1. standard boundary treatment1623 ! ------------------------------1624 ! 2. East and west directions exchange1625 ! ------------------------------------1626 ! we play with the neigbours AND the row number because of the periodicity1627 !1628 SELECT CASE ( nbondi ) ! Read lateral conditions1629 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1630 iihom = nlci - jpreci1631 DO jl = 1, jpreci1632 zt2ew(:,jl,1) = pt2d(jl ,:) ; pt2d(jl ,:) = 0.0_wp1633 zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp1634 END DO1635 END SELECT1636 !1637 ! ! Migrations1638 imigr = jpreci * jpj1639 !1640 SELECT CASE ( nbondi )1641 CASE ( -1 )1642 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )1643 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )1644 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1645 CASE ( 0 )1646 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )1647 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )1648 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )1649 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )1650 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1651 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1652 CASE ( 1 )1653 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )1654 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )1655 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1656 END SELECT1657 !1658 ! ! Write lateral conditions1659 iihom = nlci-nreci1660 !1661 SELECT CASE ( nbondi )1662 CASE ( -1 )1663 DO jl = 1, jpreci1664 pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2)1665 END DO1666 CASE ( 0 )1667 DO jl = 1, jpreci1668 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2)1669 pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2)1670 END DO1671 CASE ( 1 )1672 DO jl = 1, jpreci1673 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2)1674 END DO1675 END SELECT1676 1677 1678 ! 3. North and south directions1679 ! -----------------------------1680 ! always closed : we play only with the neigbours1681 !1682 IF( nbondj /= 2 ) THEN ! Read lateral conditions1683 ijhom = nlcj - jprecj1684 DO jl = 1, jprecj1685 zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp1686 zt2ns(:,jl,1) = pt2d(:,jl ) ; pt2d(:,jl ) = 0.0_wp1687 END DO1688 ENDIF1689 !1690 ! ! Migrations1691 imigr = jprecj * jpi1692 !1693 SELECT CASE ( nbondj )1694 CASE ( -1 )1695 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )1696 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )1697 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1698 CASE ( 0 )1699 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )1700 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )1701 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )1702 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )1703 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1704 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1705 CASE ( 1 )1706 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )1707 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )1708 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1709 END SELECT1710 !1711 ! ! Write lateral conditions1712 ijhom = nlcj-nrecj1713 !1714 SELECT CASE ( nbondj )1715 CASE ( -1 )1716 DO jl = 1, jprecj1717 pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2)1718 END DO1719 CASE ( 0 )1720 DO jl = 1, jprecj1721 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2)1722 pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2)1723 END DO1724 CASE ( 1 )1725 DO jl = 1, jprecj1726 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2)1727 END DO1728 END SELECT1729 1730 ! 4. north fold treatment1731 ! -----------------------1732 !1733 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN1734 !1735 SELECT CASE ( jpni )1736 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp1737 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.1738 END SELECT1739 !1740 ENDIF1741 !1742 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )1743 !1744 END SUBROUTINE mpp_lnk_sum_2d1745 1746 1747 687 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) 1748 688 !!---------------------------------------------------------------------- … … 1845 785 END SUBROUTINE mppscatter 1846 786 1847 787 !!---------------------------------------------------------------------- 788 !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** 789 !! 790 !!---------------------------------------------------------------------- 791 !! 1848 792 SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 1849 !!----------------------------------------------------------------------1850 !! *** routine mppmax_a_int ***1851 !!1852 !! ** Purpose : Find maximum value in an integer layout array1853 !!1854 793 !!---------------------------------------------------------------------- 1855 794 INTEGER , INTENT(in ) :: kdim ! size of array 1856 795 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1857 796 INTEGER , INTENT(in ), OPTIONAL :: kcom ! 1858 ! 1859 INTEGER :: ierror, localcomm ! temporary integer 797 INTEGER :: ierror, ilocalcomm ! temporary integer 1860 798 INTEGER, DIMENSION(kdim) :: iwork 1861 799 !!---------------------------------------------------------------------- 1862 ! 1863 localcomm = mpi_comm_opa 1864 IF( PRESENT(kcom) ) localcomm = kcom 1865 ! 1866 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror ) 1867 ! 800 ilocalcomm = mpi_comm_opa 801 IF( PRESENT(kcom) ) ilocalcomm = kcom 802 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror ) 1868 803 ktab(:) = iwork(:) 1869 !1870 804 END SUBROUTINE mppmax_a_int 1871 1872 805 !! 1873 806 SUBROUTINE mppmax_int( ktab, kcom ) 1874 !!----------------------------------------------------------------------1875 !! *** routine mppmax_int ***1876 !!1877 !! ** Purpose : Find maximum value in an integer layout array1878 !!1879 807 !!---------------------------------------------------------------------- 1880 808 INTEGER, INTENT(inout) :: ktab ! ??? 1881 809 INTEGER, INTENT(in ), OPTIONAL :: kcom ! ??? 1882 ! 1883 INTEGER :: ierror, iwork, localcomm ! temporary integer 1884 !!---------------------------------------------------------------------- 1885 ! 1886 localcomm = mpi_comm_opa 1887 IF( PRESENT(kcom) ) localcomm = kcom 1888 ! 1889 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 1890 ! 810 INTEGER :: ierror, iwork, ilocalcomm ! temporary integer 811 !!---------------------------------------------------------------------- 812 ilocalcomm = mpi_comm_opa 813 IF( PRESENT(kcom) ) ilocalcomm = kcom 814 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, ilocalcomm, ierror ) 1891 815 ktab = iwork 1892 !1893 816 END SUBROUTINE mppmax_int 1894 1895 817 !! 818 SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 819 !!---------------------------------------------------------------------- 820 REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab 821 INTEGER , INTENT(in ) :: kdim 822 INTEGER , OPTIONAL , INTENT(in ) :: kcom 823 INTEGER :: ierror, ilocalcomm 824 REAL(wp), DIMENSION(kdim) :: zwork 825 !!---------------------------------------------------------------------- 826 ilocalcomm = mpi_comm_opa 827 IF( PRESENT(kcom) ) ilocalcomm = kcom 828 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 829 ptab(:) = zwork(:) 830 END SUBROUTINE mppmax_a_real 831 !! 832 SUBROUTINE mppmax_real( ptab, kcom ) 833 !!---------------------------------------------------------------------- 834 REAL(wp), INTENT(inout) :: ptab ! ??? 835 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 836 INTEGER :: ierror, ilocalcomm 837 REAL(wp) :: zwork 838 !!---------------------------------------------------------------------- 839 ilocalcomm = mpi_comm_opa 840 IF( PRESENT(kcom) ) ilocalcomm = kcom! 841 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 842 ptab = zwork 843 END SUBROUTINE mppmax_real 844 845 846 !!---------------------------------------------------------------------- 847 !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** 848 !! 849 !!---------------------------------------------------------------------- 850 !! 1896 851 SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 1897 !!----------------------------------------------------------------------1898 !! *** routine mppmin_a_int ***1899 !!1900 !! ** Purpose : Find minimum value in an integer layout array1901 !!1902 852 !!---------------------------------------------------------------------- 1903 853 INTEGER , INTENT( in ) :: kdim ! size of array … … 1905 855 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 1906 856 !! 1907 INTEGER :: ierror, localcomm ! temporary integer857 INTEGER :: ierror, ilocalcomm ! temporary integer 1908 858 INTEGER, DIMENSION(kdim) :: iwork 1909 859 !!---------------------------------------------------------------------- 1910 ! 1911 localcomm = mpi_comm_opa 1912 IF( PRESENT(kcom) ) localcomm = kcom 1913 ! 1914 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror ) 1915 ! 860 ilocalcomm = mpi_comm_opa 861 IF( PRESENT(kcom) ) ilocalcomm = kcom 862 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror ) 1916 863 ktab(:) = iwork(:) 1917 !1918 864 END SUBROUTINE mppmin_a_int 1919 1920 865 !! 1921 866 SUBROUTINE mppmin_int( ktab, kcom ) 1922 !!----------------------------------------------------------------------1923 !! *** routine mppmin_int ***1924 !!1925 !! ** Purpose : Find minimum value in an integer layout array1926 !!1927 867 !!---------------------------------------------------------------------- 1928 868 INTEGER, INTENT(inout) :: ktab ! ??? 1929 869 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 1930 870 !! 1931 INTEGER :: ierror, iwork, localcomm 1932 !!---------------------------------------------------------------------- 1933 ! 1934 localcomm = mpi_comm_opa 1935 IF( PRESENT(kcom) ) localcomm = kcom 1936 ! 1937 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 1938 ! 871 INTEGER :: ierror, iwork, ilocalcomm 872 !!---------------------------------------------------------------------- 873 ilocalcomm = mpi_comm_opa 874 IF( PRESENT(kcom) ) ilocalcomm = kcom 875 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, ilocalcomm, ierror ) 1939 876 ktab = iwork 1940 !1941 877 END SUBROUTINE mppmin_int 1942 1943 878 !! 879 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 880 !!---------------------------------------------------------------------- 881 INTEGER , INTENT(in ) :: kdim 882 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 883 INTEGER , INTENT(in ), OPTIONAL :: kcom 884 INTEGER :: ierror, ilocalcomm 885 REAL(wp), DIMENSION(kdim) :: zwork 886 !!----------------------------------------------------------------------- 887 ilocalcomm = mpi_comm_opa 888 IF( PRESENT(kcom) ) ilocalcomm = kcom 889 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 890 ptab(:) = zwork(:) 891 END SUBROUTINE mppmin_a_real 892 !! 893 SUBROUTINE mppmin_real( ptab, kcom ) 894 !!----------------------------------------------------------------------- 895 REAL(wp), INTENT(inout) :: ptab ! 896 INTEGER , INTENT(in ), OPTIONAL :: kcom 897 INTEGER :: ierror, ilocalcomm 898 REAL(wp) :: zwork 899 !!----------------------------------------------------------------------- 900 ilocalcomm = mpi_comm_opa 901 IF( PRESENT(kcom) ) ilocalcomm = kcom 902 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 903 ptab = zwork 904 END SUBROUTINE mppmin_real 905 906 907 !!---------------------------------------------------------------------- 908 !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** 909 !! 910 !! Global sum of 1D array or a variable (integer, real or complex) 911 !!---------------------------------------------------------------------- 912 !! 1944 913 SUBROUTINE mppsum_a_int( ktab, kdim ) 1945 !!----------------------------------------------------------------------1946 !! *** routine mppsum_a_int ***1947 !!1948 !! ** Purpose : Global integer sum, 1D array case1949 !!1950 914 !!---------------------------------------------------------------------- 1951 915 INTEGER, INTENT(in ) :: kdim ! ??? 1952 916 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? 1953 !1954 917 INTEGER :: ierror 1955 918 INTEGER, DIMENSION (kdim) :: iwork 1956 919 !!---------------------------------------------------------------------- 1957 !1958 920 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 1959 !1960 921 ktab(:) = iwork(:) 1961 !1962 922 END SUBROUTINE mppsum_a_int 1963 1964 923 !! 1965 924 SUBROUTINE mppsum_int( ktab ) 1966 925 !!---------------------------------------------------------------------- 1967 !! *** routine mppsum_int ***1968 !!1969 !! ** Purpose : Global integer sum1970 !!1971 !!----------------------------------------------------------------------1972 926 INTEGER, INTENT(inout) :: ktab 1973 !!1974 927 INTEGER :: ierror, iwork 1975 928 !!---------------------------------------------------------------------- 1976 !1977 929 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 1978 !1979 930 ktab = iwork 1980 !1981 931 END SUBROUTINE mppsum_int 1982 1983 1984 SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 1985 !!---------------------------------------------------------------------- 1986 !! *** routine mppmax_a_real *** 1987 !! 1988 !! ** Purpose : Maximum of a 1D array 1989 !! 1990 !!---------------------------------------------------------------------- 1991 REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab 1992 INTEGER , INTENT(in ) :: kdim 1993 INTEGER , OPTIONAL , INTENT(in ) :: kcom 1994 ! 1995 INTEGER :: ierror, localcomm 1996 REAL(wp), DIMENSION(kdim) :: zwork 1997 !!---------------------------------------------------------------------- 1998 ! 1999 localcomm = mpi_comm_opa 2000 IF( PRESENT(kcom) ) localcomm = kcom 2001 ! 2002 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 932 !! 933 SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 934 !!----------------------------------------------------------------------- 935 INTEGER , INTENT(in ) :: kdim ! size of ptab 936 REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab ! input array 937 INTEGER , OPTIONAL , INTENT(in ) :: kcom ! specific communicator 938 INTEGER :: ierror, ilocalcomm ! local integer 939 REAL(wp) :: zwork(kdim) ! local workspace 940 !!----------------------------------------------------------------------- 941 ilocalcomm = mpi_comm_opa 942 IF( PRESENT(kcom) ) ilocalcomm = kcom 943 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 2003 944 ptab(:) = zwork(:) 2004 ! 2005 END SUBROUTINE mppmax_a_real 2006 2007 2008 SUBROUTINE mppmax_real( ptab, kcom ) 945 END SUBROUTINE mppsum_a_real 946 !! 947 SUBROUTINE mppsum_real( ptab, kcom ) 948 !!----------------------------------------------------------------------- 949 REAL(wp) , INTENT(inout) :: ptab ! input scalar 950 INTEGER , OPTIONAL, INTENT(in ) :: kcom 951 INTEGER :: ierror, ilocalcomm 952 REAL(wp) :: zwork 953 !!----------------------------------------------------------------------- 954 ilocalcomm = mpi_comm_opa 955 IF( PRESENT(kcom) ) ilocalcomm = kcom 956 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 957 ptab = zwork 958 END SUBROUTINE mppsum_real 959 !! 960 SUBROUTINE mppsum_realdd( ytab, kcom ) 961 !!----------------------------------------------------------------------- 962 COMPLEX(wp) , INTENT(inout) :: ytab ! input scalar 963 INTEGER , OPTIONAL, INTENT(in ) :: kcom 964 INTEGER :: ierror, ilocalcomm 965 COMPLEX(wp) :: zwork 966 !!----------------------------------------------------------------------- 967 ilocalcomm = mpi_comm_opa 968 IF( PRESENT(kcom) ) ilocalcomm = kcom 969 CALL MPI_ALLREDUCE( ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 970 ytab = zwork 971 END SUBROUTINE mppsum_realdd 972 !! 973 SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 974 !!---------------------------------------------------------------------- 975 INTEGER , INTENT(in ) :: kdim ! size of ytab 976 COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array 977 INTEGER , OPTIONAL , INTENT(in ) :: kcom 978 INTEGER:: ierror, ilocalcomm ! local integer 979 COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace 980 !!----------------------------------------------------------------------- 981 ilocalcomm = mpi_comm_opa 982 IF( PRESENT(kcom) ) ilocalcomm = kcom 983 CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 984 ytab(:) = zwork(:) 985 END SUBROUTINE mppsum_a_realdd 986 987 988 SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom ) 2009 989 !!---------------------------------------------------------------------- 2010 990 !! *** routine mppmax_real *** 2011 991 !! 2012 !! ** Purpose : Maximum for each element of a 1D array 2013 !! 2014 !!---------------------------------------------------------------------- 2015 REAL(wp), INTENT(inout) :: ptab ! ??? 2016 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 2017 !! 2018 INTEGER :: ierror, localcomm 2019 REAL(wp) :: zwork 2020 !!---------------------------------------------------------------------- 2021 ! 2022 localcomm = mpi_comm_opa 2023 IF( PRESENT(kcom) ) localcomm = kcom 2024 ! 2025 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror ) 2026 ptab = zwork 2027 ! 2028 END SUBROUTINE mppmax_real 2029 2030 2031 SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom ) 2032 !!---------------------------------------------------------------------- 2033 !! *** routine mppmax_real *** 2034 !! 2035 !! ** Purpose : Maximum 992 !! ** Purpose : Maximum across processor of each element of a 1D arrays 2036 993 !! 2037 994 !!---------------------------------------------------------------------- … … 2040 997 INTEGER , OPTIONAL , INTENT(in ) :: kcom ! local communicator 2041 998 !! 2042 INTEGER :: ierror, localcomm999 INTEGER :: ierror, ilocalcomm 2043 1000 REAL(wp), DIMENSION(kdim) :: zwork 2044 1001 !!---------------------------------------------------------------------- 2045 ! 2046 localcomm = mpi_comm_opa 2047 IF( PRESENT(kcom) ) localcomm = kcom 2048 ! 2049 CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 1002 ilocalcomm = mpi_comm_opa 1003 IF( PRESENT(kcom) ) ilocalcomm = kcom 1004 ! 1005 CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 2050 1006 pt1d(:) = zwork(:) 2051 1007 ! 2052 1008 END SUBROUTINE mppmax_real_multiple 2053 2054 2055 SUBROUTINE mppmin_a_real( ptab, kdim, kcom )2056 !!----------------------------------------------------------------------2057 !! *** routine mppmin_a_real ***2058 !!2059 !! ** Purpose : Minimum of REAL, array case2060 !!2061 !!-----------------------------------------------------------------------2062 INTEGER , INTENT(in ) :: kdim2063 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab2064 INTEGER , INTENT(in ), OPTIONAL :: kcom2065 !!2066 INTEGER :: ierror, localcomm2067 REAL(wp), DIMENSION(kdim) :: zwork2068 !!-----------------------------------------------------------------------2069 !2070 localcomm = mpi_comm_opa2071 IF( PRESENT(kcom) ) localcomm = kcom2072 !2073 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )2074 ptab(:) = zwork(:)2075 !2076 END SUBROUTINE mppmin_a_real2077 2078 2079 SUBROUTINE mppmin_real( ptab, kcom )2080 !!----------------------------------------------------------------------2081 !! *** routine mppmin_real ***2082 !!2083 !! ** Purpose : minimum of REAL, scalar case2084 !!2085 !!-----------------------------------------------------------------------2086 REAL(wp), INTENT(inout) :: ptab !2087 INTEGER , INTENT(in ), OPTIONAL :: kcom2088 !!2089 INTEGER :: ierror2090 REAL(wp) :: zwork2091 INTEGER :: localcomm2092 !!-----------------------------------------------------------------------2093 !2094 localcomm = mpi_comm_opa2095 IF( PRESENT(kcom) ) localcomm = kcom2096 !2097 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )2098 ptab = zwork2099 !2100 END SUBROUTINE mppmin_real2101 2102 2103 SUBROUTINE mppsum_a_real( ptab, kdim, kcom )2104 !!----------------------------------------------------------------------2105 !! *** routine mppsum_a_real ***2106 !!2107 !! ** Purpose : global sum, REAL ARRAY argument case2108 !!2109 !!-----------------------------------------------------------------------2110 INTEGER , INTENT( in ) :: kdim ! size of ptab2111 REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array2112 INTEGER , INTENT( in ), OPTIONAL :: kcom2113 !!2114 INTEGER :: ierror ! temporary integer2115 INTEGER :: localcomm2116 REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace2117 !!-----------------------------------------------------------------------2118 !2119 localcomm = mpi_comm_opa2120 IF( PRESENT(kcom) ) localcomm = kcom2121 !2122 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )2123 ptab(:) = zwork(:)2124 !2125 END SUBROUTINE mppsum_a_real2126 2127 2128 SUBROUTINE mppsum_real( ptab, kcom )2129 !!----------------------------------------------------------------------2130 !! *** routine mppsum_real ***2131 !!2132 !! ** Purpose : global sum, SCALAR argument case2133 !!2134 !!-----------------------------------------------------------------------2135 REAL(wp), INTENT(inout) :: ptab ! input scalar2136 INTEGER , INTENT(in ), OPTIONAL :: kcom2137 !!2138 INTEGER :: ierror, localcomm2139 REAL(wp) :: zwork2140 !!-----------------------------------------------------------------------2141 !2142 localcomm = mpi_comm_opa2143 IF( PRESENT(kcom) ) localcomm = kcom2144 !2145 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )2146 ptab = zwork2147 !2148 END SUBROUTINE mppsum_real2149 2150 2151 SUBROUTINE mppsum_realdd( ytab, kcom )2152 !!----------------------------------------------------------------------2153 !! *** routine mppsum_realdd ***2154 !!2155 !! ** Purpose : global sum in Massively Parallel Processing2156 !! SCALAR argument case for double-double precision2157 !!2158 !!-----------------------------------------------------------------------2159 COMPLEX(wp), INTENT(inout) :: ytab ! input scalar2160 INTEGER , INTENT(in ), OPTIONAL :: kcom2161 !2162 INTEGER :: ierror2163 INTEGER :: localcomm2164 COMPLEX(wp) :: zwork2165 !!-----------------------------------------------------------------------2166 !2167 localcomm = mpi_comm_opa2168 IF( PRESENT(kcom) ) localcomm = kcom2169 !2170 ! reduce local sums into global sum2171 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror )2172 ytab = zwork2173 !2174 END SUBROUTINE mppsum_realdd2175 2176 2177 SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )2178 !!----------------------------------------------------------------------2179 !! *** routine mppsum_a_realdd ***2180 !!2181 !! ** Purpose : global sum in Massively Parallel Processing2182 !! COMPLEX ARRAY case for double-double precision2183 !!2184 !!-----------------------------------------------------------------------2185 INTEGER , INTENT(in ) :: kdim ! size of ytab2186 COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array2187 INTEGER , OPTIONAL , INTENT(in ) :: kcom2188 !2189 INTEGER:: ierror, localcomm ! local integer2190 COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace2191 !!-----------------------------------------------------------------------2192 !2193 localcomm = mpi_comm_opa2194 IF( PRESENT(kcom) ) localcomm = kcom2195 !2196 CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror )2197 ytab(:) = zwork(:)2198 !2199 END SUBROUTINE mppsum_a_realdd2200 1009 2201 1010 … … 2649 1458 2650 1459 2651 SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )2652 !!---------------------------------------------------------------------2653 !! *** routine mpp_lbc_north_3d ***2654 !!2655 !! ** Purpose : Ensure proper north fold horizontal bondary condition2656 !! in mpp configuration in case of jpn1 > 12657 !!2658 !! ** Method : North fold condition and mpp with more than one proc2659 !! in i-direction require a specific treatment. We gather2660 !! the 4 northern lines of the global domain on 1 processor2661 !! and apply lbc north-fold on this sub array. Then we2662 !! scatter the north fold array back to the processors.2663 !!----------------------------------------------------------------------2664 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied2665 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points2666 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold2667 !2668 INTEGER :: ji, jj, jr, jk2669 INTEGER :: ipk ! 3rd dimension of the input array2670 INTEGER :: ierr, itaille, ildi, ilei, iilb2671 INTEGER :: ijpj, ijpjm1, ij, iproc2672 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather2673 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather2674 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather2675 ! ! Workspace for message transfers avoiding mpi_allgather2676 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab2677 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk2678 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio2679 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr2680 2681 INTEGER :: istatus(mpi_status_size)2682 INTEGER :: iflag2683 !!----------------------------------------------------------------------2684 !2685 ipk = SIZE( pt3d, 3 )2686 !2687 ALLOCATE( ztab (jpiglo,4,ipk), znorthloc(jpi,4,ipk), zfoldwk(jpi,4,ipk), znorthgloio(jpi,4,ipk,jpni) )2688 ALLOCATE( ztabl(jpi ,4,ipk), ztabr(jpi*jpmaxngh,4,ipk) )2689 2690 ijpj = 42691 ijpjm1 = 32692 !2693 znorthloc(:,:,:) = 0._wp2694 DO jk = 1, ipk2695 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d2696 ij = jj - nlcj + ijpj2697 znorthloc(:,ij,jk) = pt3d(:,jj,jk)2698 END DO2699 END DO2700 !2701 ! ! Build in procs of ncomm_north the znorthgloio2702 itaille = jpi * ipk * ijpj2703 2704 IF ( l_north_nogather ) THEN2705 !2706 ztabr(:,:,:) = 0._wp2707 ztabl(:,:,:) = 0._wp2708 2709 DO jk = 1, ipk2710 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array2711 ij = jj - nlcj + ijpj2712 DO ji = nfsloop, nfeloop2713 ztabl(ji,ij,jk) = pt3d(ji,jj,jk)2714 END DO2715 END DO2716 END DO2717 2718 DO jr = 1,nsndto2719 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN2720 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )2721 ENDIF2722 END DO2723 DO jr = 1,nsndto2724 iproc = nfipproc(isendto(jr),jpnj)2725 IF(iproc /= -1) THEN2726 ilei = nleit (iproc+1)2727 ildi = nldit (iproc+1)2728 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)2729 ENDIF2730 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN2731 CALL mpprecv(5, zfoldwk, itaille, iproc)2732 DO jk = 1, ipk2733 DO jj = 1, ijpj2734 DO ji = ildi, ilei2735 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)2736 END DO2737 END DO2738 END DO2739 ELSE IF( iproc == narea-1 ) THEN2740 DO jk = 1, ipk2741 DO jj = 1, ijpj2742 DO ji = ildi, ilei2743 ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)2744 END DO2745 END DO2746 END DO2747 ENDIF2748 END DO2749 IF (l_isend) THEN2750 DO jr = 1,nsndto2751 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN2752 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )2753 ENDIF2754 END DO2755 ENDIF2756 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition2757 DO jk = 1, ipk2758 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d2759 ij = jj - nlcj + ijpj2760 DO ji= 1, nlci2761 pt3d(ji,jj,jk) = ztabl(ji,ij,jk)2762 END DO2763 END DO2764 END DO2765 !2766 ELSE2767 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &2768 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2769 !2770 ztab(:,:,:) = 0._wp2771 DO jr = 1, ndim_rank_north ! recover the global north array2772 iproc = nrank_north(jr) + 12773 ildi = nldit (iproc)2774 ilei = nleit (iproc)2775 iilb = nimppt(iproc)2776 DO jk = 1, ipk2777 DO jj = 1, ijpj2778 DO ji = ildi, ilei2779 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)2780 END DO2781 END DO2782 END DO2783 END DO2784 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition2785 !2786 DO jk = 1, ipk2787 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d2788 ij = jj - nlcj + ijpj2789 DO ji= 1, nlci2790 pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)2791 END DO2792 END DO2793 END DO2794 !2795 ENDIF2796 !2797 ! The ztab array has been either:2798 ! a. Fully populated by the mpi_allgather operation or2799 ! b. Had the active points for this domain and northern neighbours populated2800 ! by peer to peer exchanges2801 ! Either way the array may be folded by lbc_nfd and the result for the span of2802 ! this domain will be identical.2803 !2804 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )2805 DEALLOCATE( ztabl, ztabr )2806 !2807 END SUBROUTINE mpp_lbc_north_3d2808 2809 2810 SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)2811 !!---------------------------------------------------------------------2812 !! *** routine mpp_lbc_north_2d ***2813 !!2814 !! ** Purpose : Ensure proper north fold horizontal bondary condition2815 !! in mpp configuration in case of jpn1 > 1 (for 2d array )2816 !!2817 !! ** Method : North fold condition and mpp with more than one proc2818 !! in i-direction require a specific treatment. We gather2819 !! the 4 northern lines of the global domain on 1 processor2820 !! and apply lbc north-fold on this sub array. Then we2821 !! scatter the north fold array back to the processors.2822 !!2823 !!----------------------------------------------------------------------2824 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the b.c. is applied2825 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d grid-points2826 ! ! = T , U , V , F or W gridpoints2827 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold2828 !! ! = 1. , the sign is kept2829 INTEGER :: ji, jj, jr2830 INTEGER :: ierr, itaille, ildi, ilei, iilb2831 INTEGER :: ijpj, ijpjm1, ij, iproc2832 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather2833 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather2834 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather2835 ! ! Workspace for message transfers avoiding mpi_allgather2836 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab2837 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: znorthloc, zfoldwk2838 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio2839 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztabl, ztabr2840 INTEGER :: istatus(mpi_status_size)2841 INTEGER :: iflag2842 !!----------------------------------------------------------------------2843 !2844 ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )2845 ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) )2846 !2847 ijpj = 42848 ijpjm1 = 32849 !2850 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d2851 ij = jj - nlcj + ijpj2852 znorthloc(:,ij) = pt2d(:,jj)2853 END DO2854 2855 ! ! Build in procs of ncomm_north the znorthgloio2856 itaille = jpi * ijpj2857 IF ( l_north_nogather ) THEN2858 !2859 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified2860 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange2861 !2862 ztabr(:,:) = 02863 ztabl(:,:) = 02864 2865 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array2866 ij = jj - nlcj + ijpj2867 DO ji = nfsloop, nfeloop2868 ztabl(ji,ij) = pt2d(ji,jj)2869 END DO2870 END DO2871 2872 DO jr = 1,nsndto2873 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN2874 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )2875 ENDIF2876 END DO2877 DO jr = 1,nsndto2878 iproc = nfipproc(isendto(jr),jpnj)2879 IF( iproc /= -1 ) THEN2880 ilei = nleit (iproc+1)2881 ildi = nldit (iproc+1)2882 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)2883 ENDIF2884 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN2885 CALL mpprecv(5, zfoldwk, itaille, iproc)2886 DO jj = 1, ijpj2887 DO ji = ildi, ilei2888 ztabr(iilb+ji,jj) = zfoldwk(ji,jj)2889 END DO2890 END DO2891 ELSEIF( iproc == narea-1 ) THEN2892 DO jj = 1, ijpj2893 DO ji = ildi, ilei2894 ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)2895 END DO2896 END DO2897 ENDIF2898 END DO2899 IF(l_isend) THEN2900 DO jr = 1,nsndto2901 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN2902 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)2903 ENDIF2904 END DO2905 ENDIF2906 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition2907 !2908 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d2909 ij = jj - nlcj + ijpj2910 DO ji = 1, nlci2911 pt2d(ji,jj) = ztabl(ji,ij)2912 END DO2913 END DO2914 !2915 ELSE2916 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &2917 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2918 !2919 ztab(:,:) = 0._wp2920 DO jr = 1, ndim_rank_north ! recover the global north array2921 iproc = nrank_north(jr) + 12922 ildi = nldit (iproc)2923 ilei = nleit (iproc)2924 iilb = nimppt(iproc)2925 DO jj = 1, ijpj2926 DO ji = ildi, ilei2927 ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)2928 END DO2929 END DO2930 END DO2931 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition2932 !2933 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d2934 ij = jj - nlcj + ijpj2935 DO ji = 1, nlci2936 pt2d(ji,jj) = ztab(ji+nimpp-1,ij)2937 END DO2938 END DO2939 !2940 ENDIF2941 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )2942 DEALLOCATE( ztabl, ztabr )2943 !2944 END SUBROUTINE mpp_lbc_north_2d2945 2946 2947 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, kfld )2948 !!---------------------------------------------------------------------2949 !! *** routine mpp_lbc_north_2d ***2950 !!2951 !! ** Purpose : Ensure proper north fold horizontal bondary condition2952 !! in mpp configuration in case of jpn1 > 12953 !! (for multiple 2d arrays )2954 !!2955 !! ** Method : North fold condition and mpp with more than one proc2956 !! in i-direction require a specific treatment. We gather2957 !! the 4 northern lines of the global domain on 1 processor2958 !! and apply lbc north-fold on this sub array. Then we2959 !! scatter the north fold array back to the processors.2960 !!2961 !!----------------------------------------------------------------------2962 TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields2963 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points2964 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold2965 INTEGER , INTENT(in ) :: kfld ! number of variables contained in pt2d2966 !2967 INTEGER :: ji, jj, jr, jk2968 INTEGER :: ierr, itaille, ildi, ilei, iilb2969 INTEGER :: ijpj, ijpjm1, ij, iproc, iflag2970 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather2971 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather2972 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather2973 ! ! Workspace for message transfers avoiding mpi_allgather2974 INTEGER :: istatus(mpi_status_size)2975 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab2976 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk2977 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio2978 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr2979 !!----------------------------------------------------------------------2980 !2981 ALLOCATE( ztab(jpiglo,4,kfld), znorthloc (jpi,4,kfld), &2982 & zfoldwk(jpi,4,kfld), znorthgloio(jpi,4,kfld,jpni), &2983 & ztabl (jpi,4,kfld), ztabr(jpi*jpmaxngh, 4,kfld) )2984 !2985 ijpj = 42986 ijpjm1 = 32987 !2988 2989 DO jk = 1, kfld2990 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable)2991 ij = jj - nlcj + ijpj2992 znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj)2993 END DO2994 END DO2995 ! ! Build in procs of ncomm_north the znorthgloio2996 itaille = jpi * ijpj2997 2998 IF ( l_north_nogather ) THEN2999 !3000 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified3001 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange3002 !3003 ztabr(:,:,:) = 0._wp3004 ztabl(:,:,:) = 0._wp3005 3006 DO jk = 1, kfld3007 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array3008 ij = jj - nlcj + ijpj3009 DO ji = nfsloop, nfeloop3010 ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj)3011 END DO3012 END DO3013 END DO3014 3015 DO jr = 1, nsndto3016 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN3017 CALL mppsend(5, znorthloc, itaille*kfld, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "kfld" times3018 ENDIF3019 END DO3020 DO jr = 1, nsndto3021 iproc = nfipproc(isendto(jr),jpnj)3022 IF( iproc /= -1 ) THEN3023 ilei = nleit (iproc+1)3024 ildi = nldit (iproc+1)3025 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)3026 ENDIF3027 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN3028 CALL mpprecv(5, zfoldwk, itaille*kfld, iproc) ! Buffer expanded "kfld" times3029 DO jk = 1 , kfld3030 DO jj = 1, ijpj3031 DO ji = ildi, ilei3032 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D3033 END DO3034 END DO3035 END DO3036 ELSEIF ( iproc == narea-1 ) THEN3037 DO jk = 1, kfld3038 DO jj = 1, ijpj3039 DO ji = ildi, ilei3040 ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D3041 END DO3042 END DO3043 END DO3044 ENDIF3045 END DO3046 IF( l_isend ) THEN3047 DO jr = 1, nsndto3048 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN3049 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)3050 ENDIF3051 END DO3052 ENDIF3053 !3054 DO ji = 1, kfld ! Loop to manage 3D variables3055 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition3056 END DO3057 !3058 DO jk = 1, kfld3059 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d3060 ij = jj - nlcj + ijpj3061 DO ji = 1, nlci3062 pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D3063 END DO3064 END DO3065 END DO3066 3067 !3068 ELSE3069 !3070 CALL MPI_ALLGATHER( znorthloc , itaille*kfld, MPI_DOUBLE_PRECISION, &3071 & znorthgloio, itaille*kfld, MPI_DOUBLE_PRECISION, ncomm_north, ierr )3072 !3073 ztab(:,:,:) = 0._wp3074 DO jk = 1, kfld3075 DO jr = 1, ndim_rank_north ! recover the global north array3076 iproc = nrank_north(jr) + 13077 ildi = nldit (iproc)3078 ilei = nleit (iproc)3079 iilb = nimppt(iproc)3080 DO jj = 1, ijpj3081 DO ji = ildi, ilei3082 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)3083 END DO3084 END DO3085 END DO3086 END DO3087 3088 DO ji = 1, kfld3089 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition3090 END DO3091 !3092 DO jk = 1, kfld3093 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d3094 ij = jj - nlcj + ijpj3095 DO ji = 1, nlci3096 pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk)3097 END DO3098 END DO3099 END DO3100 !3101 !3102 ENDIF3103 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )3104 DEALLOCATE( ztabl, ztabr )3105 !3106 END SUBROUTINE mpp_lbc_north_2d_multiple3107 3108 3109 1460 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 3110 1461 !!--------------------------------------------------------------------- … … 3165 1516 ! 2. North-Fold boundary conditions 3166 1517 ! ---------------------------------- 3167 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )1518 !!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 3168 1519 3169 1520 ij = jpr2dj … … 3179 1530 ! 3180 1531 END SUBROUTINE mpp_lbc_north_e 3181 3182 3183 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )3184 !!----------------------------------------------------------------------3185 !! *** routine mpp_lnk_bdy_3d ***3186 !!3187 !! ** Purpose : Message passing management3188 !!3189 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries3190 !! between processors following neighboring subdomains.3191 !! domain parameters3192 !! nlci : first dimension of the local subdomain3193 !! nlcj : second dimension of the local subdomain3194 !! nbondi_bdy : mark for "east-west local boundary"3195 !! nbondj_bdy : mark for "north-south local boundary"3196 !! noea : number for local neighboring processors3197 !! nowe : number for local neighboring processors3198 !! noso : number for local neighboring processors3199 !! nono : number for local neighboring processors3200 !!3201 !! ** Action : ptab with update value at its periphery3202 !!3203 !!----------------------------------------------------------------------3204 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied3205 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab grid point3206 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary3207 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set3208 !3209 INTEGER :: ji, jj, jk, jl ! dummy loop indices3210 INTEGER :: ipk ! 3rd dimension of the input array3211 INTEGER :: imigr, iihom, ijhom ! local integers3212 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend3213 REAL(wp) :: zland ! local scalar3214 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend3215 !3216 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north3217 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east3218 !!----------------------------------------------------------------------3219 !3220 ipk = SIZE( ptab, 3 )3221 !3222 ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2), &3223 & zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2) )3224 3225 zland = 0._wp3226 3227 ! 1. standard boundary treatment3228 ! ------------------------------3229 ! ! East-West boundaries3230 ! !* Cyclic3231 IF( nbondi == 2) THEN3232 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN3233 ptab( 1 ,:,:) = ptab(jpim1,:,:)3234 ptab(jpi,:,:) = ptab( 2 ,:,:)3235 ELSE3236 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point3237 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north3238 ENDIF3239 ELSEIF(nbondi == -1) THEN3240 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point3241 ELSEIF(nbondi == 1) THEN3242 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north3243 ENDIF !* closed3244 3245 IF (nbondj == 2 .OR. nbondj == -1) THEN3246 IF( .NOT. cd_type == 'F' ) ptab(:,1:jprecj,:) = zland ! south except F-point3247 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN3248 ptab(:,nlcj-jprecj+1:jpj,:) = zland ! north3249 ENDIF3250 !3251 ! 2. East and west directions exchange3252 ! ------------------------------------3253 ! we play with the neigbours AND the row number because of the periodicity3254 !3255 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions3256 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)3257 iihom = nlci-nreci3258 DO jl = 1, jpreci3259 zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)3260 zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)3261 END DO3262 END SELECT3263 !3264 ! ! Migrations3265 imigr = jpreci * jpj * ipk3266 !3267 SELECT CASE ( nbondi_bdy(ib_bdy) )3268 CASE ( -1 )3269 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )3270 CASE ( 0 )3271 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )3272 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )3273 CASE ( 1 )3274 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )3275 END SELECT3276 !3277 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3278 CASE ( -1 )3279 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )3280 CASE ( 0 )3281 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )3282 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )3283 CASE ( 1 )3284 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )3285 END SELECT3286 !3287 SELECT CASE ( nbondi_bdy(ib_bdy) )3288 CASE ( -1 )3289 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3290 CASE ( 0 )3291 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3292 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)3293 CASE ( 1 )3294 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3295 END SELECT3296 !3297 ! ! Write Dirichlet lateral conditions3298 iihom = nlci-jpreci3299 !3300 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3301 CASE ( -1 )3302 DO jl = 1, jpreci3303 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)3304 END DO3305 CASE ( 0 )3306 DO jl = 1, jpreci3307 ptab( jl,:,:) = zt3we(:,jl,:,2)3308 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)3309 END DO3310 CASE ( 1 )3311 DO jl = 1, jpreci3312 ptab( jl,:,:) = zt3we(:,jl,:,2)3313 END DO3314 END SELECT3315 3316 ! 3. North and south directions3317 ! -----------------------------3318 ! always closed : we play only with the neigbours3319 !3320 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions3321 ijhom = nlcj-nrecj3322 DO jl = 1, jprecj3323 zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)3324 zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)3325 END DO3326 ENDIF3327 !3328 ! ! Migrations3329 imigr = jprecj * jpi * ipk3330 !3331 SELECT CASE ( nbondj_bdy(ib_bdy) )3332 CASE ( -1 )3333 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )3334 CASE ( 0 )3335 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )3336 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )3337 CASE ( 1 )3338 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )3339 END SELECT3340 !3341 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3342 CASE ( -1 )3343 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )3344 CASE ( 0 )3345 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )3346 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )3347 CASE ( 1 )3348 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )3349 END SELECT3350 !3351 SELECT CASE ( nbondj_bdy(ib_bdy) )3352 CASE ( -1 )3353 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3354 CASE ( 0 )3355 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3356 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)3357 CASE ( 1 )3358 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3359 END SELECT3360 !3361 ! ! Write Dirichlet lateral conditions3362 ijhom = nlcj-jprecj3363 !3364 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3365 CASE ( -1 )3366 DO jl = 1, jprecj3367 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)3368 END DO3369 CASE ( 0 )3370 DO jl = 1, jprecj3371 ptab(:,jl ,:) = zt3sn(:,jl,:,2)3372 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)3373 END DO3374 CASE ( 1 )3375 DO jl = 1, jprecj3376 ptab(:,jl,:) = zt3sn(:,jl,:,2)3377 END DO3378 END SELECT3379 3380 ! 4. north fold treatment3381 ! -----------------------3382 !3383 IF( npolj /= 0) THEN3384 !3385 SELECT CASE ( jpni )3386 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp3387 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.3388 END SELECT3389 !3390 ENDIF3391 !3392 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )3393 !3394 END SUBROUTINE mpp_lnk_bdy_3d3395 3396 3397 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )3398 !!----------------------------------------------------------------------3399 !! *** routine mpp_lnk_bdy_2d ***3400 !!3401 !! ** Purpose : Message passing management3402 !!3403 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries3404 !! between processors following neighboring subdomains.3405 !! domain parameters3406 !! nlci : first dimension of the local subdomain3407 !! nlcj : second dimension of the local subdomain3408 !! nbondi_bdy : mark for "east-west local boundary"3409 !! nbondj_bdy : mark for "north-south local boundary"3410 !! noea : number for local neighboring processors3411 !! nowe : number for local neighboring processors3412 !! noso : number for local neighboring processors3413 !! nono : number for local neighboring processors3414 !!3415 !! ** Action : ptab with update value at its periphery3416 !!3417 !!----------------------------------------------------------------------3418 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied3419 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points3420 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary3421 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set3422 !3423 INTEGER :: ji, jj, jl ! dummy loop indices3424 INTEGER :: imigr, iihom, ijhom ! local integers3425 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend3426 REAL(wp) :: zland3427 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend3428 !3429 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north3430 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east3431 !!----------------------------------------------------------------------3432 3433 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &3434 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )3435 3436 zland = 0._wp3437 3438 ! 1. standard boundary treatment3439 ! ------------------------------3440 ! ! East-West boundaries3441 ! !* Cyclic3442 IF( nbondi == 2 ) THEN3443 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN3444 ptab( 1 ,:) = ptab(jpim1,:)3445 ptab(jpi,:) = ptab( 2 ,:)3446 ELSE3447 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point3448 ptab(nlci-jpreci+1:jpi ,:) = zland ! north3449 ENDIF3450 ELSEIF(nbondi == -1) THEN3451 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point3452 ELSEIF(nbondi == 1) THEN3453 ptab(nlci-jpreci+1:jpi ,:) = zland ! north3454 ENDIF3455 ! !* closed3456 IF( nbondj == 2 .OR. nbondj == -1 ) THEN3457 IF( .NOT.cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point3458 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN3459 ptab(:,nlcj-jprecj+1:jpj ) = zland ! north3460 ENDIF3461 !3462 ! 2. East and west directions exchange3463 ! ------------------------------------3464 ! we play with the neigbours AND the row number because of the periodicity3465 !3466 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions3467 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)3468 iihom = nlci-nreci3469 DO jl = 1, jpreci3470 zt2ew(:,jl,1) = ptab(jpreci+jl,:)3471 zt2we(:,jl,1) = ptab(iihom +jl,:)3472 END DO3473 END SELECT3474 !3475 ! ! Migrations3476 imigr = jpreci * jpj3477 !3478 SELECT CASE ( nbondi_bdy(ib_bdy) )3479 CASE ( -1 )3480 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )3481 CASE ( 0 )3482 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )3483 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )3484 CASE ( 1 )3485 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )3486 END SELECT3487 !3488 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3489 CASE ( -1 )3490 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )3491 CASE ( 0 )3492 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )3493 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )3494 CASE ( 1 )3495 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )3496 END SELECT3497 !3498 SELECT CASE ( nbondi_bdy(ib_bdy) )3499 CASE ( -1 )3500 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3501 CASE ( 0 )3502 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3503 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )3504 CASE ( 1 )3505 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )3506 END SELECT3507 !3508 ! ! Write Dirichlet lateral conditions3509 iihom = nlci-jpreci3510 !3511 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3512 CASE ( -1 )3513 DO jl = 1, jpreci3514 ptab(iihom+jl,:) = zt2ew(:,jl,2)3515 END DO3516 CASE ( 0 )3517 DO jl = 1, jpreci3518 ptab(jl ,:) = zt2we(:,jl,2)3519 ptab(iihom+jl,:) = zt2ew(:,jl,2)3520 END DO3521 CASE ( 1 )3522 DO jl = 1, jpreci3523 ptab(jl ,:) = zt2we(:,jl,2)3524 END DO3525 END SELECT3526 3527 3528 ! 3. North and south directions3529 ! -----------------------------3530 ! always closed : we play only with the neigbours3531 !3532 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions3533 ijhom = nlcj-nrecj3534 DO jl = 1, jprecj3535 zt2sn(:,jl,1) = ptab(:,ijhom +jl)3536 zt2ns(:,jl,1) = ptab(:,jprecj+jl)3537 END DO3538 ENDIF3539 !3540 ! ! Migrations3541 imigr = jprecj * jpi3542 !3543 SELECT CASE ( nbondj_bdy(ib_bdy) )3544 CASE ( -1 )3545 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )3546 CASE ( 0 )3547 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )3548 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )3549 CASE ( 1 )3550 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )3551 END SELECT3552 !3553 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3554 CASE ( -1 )3555 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )3556 CASE ( 0 )3557 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )3558 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )3559 CASE ( 1 )3560 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )3561 END SELECT3562 !3563 SELECT CASE ( nbondj_bdy(ib_bdy) )3564 CASE ( -1 )3565 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )3566 CASE ( 0 )3567 IF(l_isend) CALL mpi_wait (ml_req1, ml_stat, ml_err )3568 IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err )3569 CASE ( 1 )3570 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )3571 END SELECT3572 !3573 ! ! Write Dirichlet lateral conditions3574 ijhom = nlcj-jprecj3575 !3576 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3577 CASE ( -1 )3578 DO jl = 1, jprecj3579 ptab(:,ijhom+jl) = zt2ns(:,jl,2)3580 END DO3581 CASE ( 0 )3582 DO jl = 1, jprecj3583 ptab(:,jl ) = zt2sn(:,jl,2)3584 ptab(:,ijhom+jl) = zt2ns(:,jl,2)3585 END DO3586 CASE ( 1 )3587 DO jl = 1, jprecj3588 ptab(:,jl) = zt2sn(:,jl,2)3589 END DO3590 END SELECT3591 3592 ! 4. north fold treatment3593 ! -----------------------3594 !3595 IF( npolj /= 0) THEN3596 !3597 SELECT CASE ( jpni )3598 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp3599 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.3600 END SELECT3601 !3602 ENDIF3603 !3604 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )3605 !3606 END SUBROUTINE mpp_lnk_bdy_2d3607 1532 3608 1533 … … 3666 1591 END SUBROUTINE mpi_init_opa 3667 1592 3668 SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 1593 1594 SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype ) 3669 1595 !!--------------------------------------------------------------------- 3670 1596 !! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD … … 3680 1606 INTEGER :: ji, ztmp ! local scalar 3681 1607 !!--------------------------------------------------------------------- 3682 1608 ! 3683 1609 ztmp = itype ! avoid compilation warning 3684 1610 ! 3685 1611 DO ji=1,ilen 3686 1612 ! Compute ydda + yddb using Knuth's trick. … … 3693 1619 yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp ) 3694 1620 END DO 3695 1621 ! 3696 1622 END SUBROUTINE DDPDD_MPI 3697 1623 … … 3763 1689 END DO 3764 1690 3765 3766 1691 ! 2. North-Fold boundary conditions 3767 1692 ! ---------------------------------- 3768 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )1693 !!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 3769 1694 3770 1695 ij = ipr2dj … … 3809 1734 ! 3810 1735 INTEGER :: jl ! dummy loop indices 3811 INTEGER :: imigr, iihom, ijhom ! temporaryintegers3812 INTEGER :: ipreci, iprecj ! temporary integers1736 INTEGER :: imigr, iihom, ijhom ! local integers 1737 INTEGER :: ipreci, iprecj ! - - 3813 1738 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3814 1739 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3815 1740 !! 3816 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 3817 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 3818 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 3819 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 1741 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns, r2dsn 1742 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe, r2dew 3820 1743 !!---------------------------------------------------------------------- 3821 1744 … … 3845 1768 ! 3846 1769 SELECT CASE ( jpni ) 3847 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )3848 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj )1770 !!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 1771 !!gm ERROR CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj ) 3849 1772 END SELECT 3850 1773 !
Note: See TracChangeset
for help on using the changeset viewer.
