- Timestamp:
- 2012-11-19T12:39:00+01:00 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2012/dev_r3365_CMCC1_BDYOBCopt/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r3294 r3592 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 21 24 !!---------------------------------------------------------------------- 22 25 … … 68 71 PUBLIC mppsize 69 72 PUBLIC lib_mpp_alloc ! Called in nemogcm.F90 73 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 74 PUBLIC mpp_lnk_obc_2d, mpp_lnk_obc_3d 70 75 71 76 !! * Interfaces … … 186 191 !!---------------------------------------------------------------------- 187 192 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 188 !! $Id $193 !! $Id: lib_mpp.F90 3294 2012-01-28 16:44:18Z rblod $ 189 194 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 190 195 !!---------------------------------------------------------------------- … … 361 366 END FUNCTION mynode 362 367 363 364 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 365 !!---------------------------------------------------------------------- 366 !! *** routine mpp_lnk_3d *** 368 SUBROUTINE mpp_lnk_obc_3d( ptab, cd_type, psgn ) 369 !!---------------------------------------------------------------------- 370 !! *** routine mpp_lnk_obc_3d *** 367 371 !! 368 372 !! ** Purpose : Message passing manadgement 369 373 !! 370 !! ** Method : Use mppsend and mpprecv function for passing mask374 !! ** Method : Use mppsend and mpprecv function for passing OBC boundaries 371 375 !! between processors following neighboring subdomains. 372 376 !! domain parameters … … 388 392 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 389 393 ! ! = 1. , the sign is kept 390 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only391 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)392 394 !! 393 395 INTEGER :: ji, jj, jk, jl ! dummy loop indices … … 398 400 !!---------------------------------------------------------------------- 399 401 400 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 401 ELSE ; zland = 0.e0 ! zero by default 402 ENDIF 402 zland = 0.e0 ! zero by default 403 403 404 404 ! 1. standard boundary treatment 405 405 ! ------------------------------ 406 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 407 ! 408 ! WARNING ptab is defined only between nld and nle 409 DO jk = 1, jpk 410 DO jj = nlcj+1, jpj ! added line(s) (inner only) 411 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 412 ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) 413 ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) 414 END DO 415 DO ji = nlci+1, jpi ! added column(s) (full) 416 ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk) 417 ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk) 418 ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk) 419 END DO 420 END DO 421 ! 422 ELSE ! standard close or cyclic treatment 423 ! 424 ! ! East-West boundaries 425 ! !* Cyclic east-west 426 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 427 ptab( 1 ,:,:) = ptab(jpim1,:,:) 428 ptab(jpi,:,:) = ptab( 2 ,:,:) 429 ELSE !* closed 430 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 431 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 432 ENDIF 433 ! ! North-South boundaries (always closed) 434 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 435 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 436 ! 406 IF( nbondi == 2) THEN 407 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 408 ptab( 1 ,:,:) = ptab(jpim1,:,:) 409 ptab(jpi,:,:) = ptab( 2 ,:,:) 410 ELSE 411 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 412 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 413 ENDIF 414 ELSEIF(nbondi == -1) THEN 415 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 416 ELSEIF(nbondi == 1) THEN 417 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 418 ENDIF !* closed 419 420 IF (nbondj == 2 .OR. nbondj == -1) THEN 421 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 422 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 423 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 437 424 ENDIF 438 425 … … 441 428 ! we play with the neigbours AND the row number because of the periodicity 442 429 ! 430 IF(nbondj .ne. 0) THEN 443 431 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 444 432 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) … … 479 467 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 480 468 END DO 481 CASE ( 0 ) 469 CASE ( 0 ) 482 470 DO jl = 1, jpreci 483 471 ptab(jl ,:,:) = t3we(:,jl,:,2) … … 489 477 END DO 490 478 END SELECT 479 ENDIF 491 480 492 481 … … 495 484 ! always closed : we play only with the neigbours 496 485 ! 486 IF(nbondi .ne. 0) THEN 497 487 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 498 488 ijhom = nlcj-nrecj … … 532 522 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 533 523 END DO 534 CASE ( 0 ) 524 CASE ( 0 ) 535 525 DO jl = 1, jprecj 536 526 ptab(:,jl ,:) = t3sn(:,jl,:,2) … … 542 532 END DO 543 533 END SELECT 534 ENDIF 544 535 545 536 … … 547 538 ! ----------------------- 548 539 ! 549 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp)) THEN540 IF( npolj /= 0 ) THEN 550 541 ! 551 542 SELECT CASE ( jpni ) … … 556 547 ENDIF 557 548 ! 558 END SUBROUTINE mpp_lnk_ 3d559 560 561 SUBROUTINE mpp_lnk_ 2d( pt2d, cd_type, psgn, cd_mpp, pval)562 !!---------------------------------------------------------------------- 563 !! *** routine mpp_lnk_ 2d ***549 END SUBROUTINE mpp_lnk_obc_3d 550 551 552 SUBROUTINE mpp_lnk_obc_2d( pt2d, cd_type, psgn ) 553 !!---------------------------------------------------------------------- 554 !! *** routine mpp_lnk_obc_2d *** 564 555 !! 565 556 !! ** Purpose : Message passing manadgement for 2d array 566 557 !! 567 !! ** Method : Use mppsend and mpprecv function for passing mask558 !! ** Method : Use mppsend and mpprecv function for passing OBC boundaries 568 559 !! between processors following neighboring subdomains. 569 560 !! domain parameters … … 583 574 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 584 575 ! ! = 1. , the sign is kept 585 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only586 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)587 576 !! 588 577 INTEGER :: ji, jj, jl ! dummy loop indices … … 593 582 !!---------------------------------------------------------------------- 594 583 595 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 596 ELSE ; zland = 0.e0 ! zero by default 597 ENDIF 584 zland = 0.e0 ! zero by default 598 585 599 586 ! 1. standard boundary treatment 600 587 ! ------------------------------ 601 588 ! 602 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 603 ! 604 ! WARNING pt2d is defined only between nld and nle 605 DO jj = nlcj+1, jpj ! added line(s) (inner only) 606 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 607 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) 608 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) 609 END DO 610 DO ji = nlci+1, jpi ! added column(s) (full) 611 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej) 612 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj ) 613 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej) 614 END DO 615 ! 616 ELSE ! standard close or cyclic treatment 617 ! 618 ! ! East-West boundaries 619 IF( nbondi == 2 .AND. & ! Cyclic east-west 620 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 621 pt2d( 1 ,:) = pt2d(jpim1,:) ! west 622 pt2d(jpi,:) = pt2d( 2 ,:) ! east 623 ELSE ! closed 624 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 625 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 626 ENDIF 627 ! ! North-South boundaries (always closed) 628 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point 629 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north 630 ! 589 IF( nbondi == 2) THEN 590 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 591 pt2d( 1 ,:) = pt2d(jpim1,:) 592 pt2d(jpi,:) = pt2d( 2 ,:) 593 ELSE 594 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 595 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 596 ENDIF 597 ELSEIF(nbondi == -1) THEN 598 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 599 ELSEIF(nbondi == 1) THEN 600 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 601 ENDIF !* closed 602 603 IF (nbondj == 2 .OR. nbondj == -1) THEN 604 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland ! south except F-point 605 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 606 pt2d(:,nlcj-jprecj+1:jpj) = zland ! north 631 607 ENDIF 632 608 … … 741 717 ! ----------------------- 742 718 ! 719 IF( npolj /= 0 ) THEN 720 ! 721 SELECT CASE ( jpni ) 722 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp 723 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. 724 END SELECT 725 ! 726 ENDIF 727 ! 728 END SUBROUTINE mpp_lnk_obc_2d 729 730 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 731 !!---------------------------------------------------------------------- 732 !! *** routine mpp_lnk_3d *** 733 !! 734 !! ** Purpose : Message passing manadgement 735 !! 736 !! ** Method : Use mppsend and mpprecv function for passing mask 737 !! between processors following neighboring subdomains. 738 !! domain parameters 739 !! nlci : first dimension of the local subdomain 740 !! nlcj : second dimension of the local subdomain 741 !! nbondi : mark for "east-west local boundary" 742 !! nbondj : mark for "north-south local boundary" 743 !! noea : number for local neighboring processors 744 !! nowe : number for local neighboring processors 745 !! noso : number for local neighboring processors 746 !! nono : number for local neighboring processors 747 !! 748 !! ** Action : ptab with update value at its periphery 749 !! 750 !!---------------------------------------------------------------------- 751 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 752 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 753 ! ! = T , U , V , F , W points 754 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 755 ! ! = 1. , the sign is kept 756 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 757 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 758 !! 759 INTEGER :: ji, jj, jk, jl ! dummy loop indices 760 INTEGER :: imigr, iihom, ijhom ! temporary integers 761 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 762 REAL(wp) :: zland 763 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 764 !!---------------------------------------------------------------------- 765 766 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 767 ELSE ; zland = 0.e0 ! zero by default 768 ENDIF 769 770 ! 1. standard boundary treatment 771 ! ------------------------------ 772 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 773 ! 774 ! WARNING ptab is defined only between nld and nle 775 DO jk = 1, jpk 776 DO jj = nlcj+1, jpj ! added line(s) (inner only) 777 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 778 ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) 779 ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) 780 END DO 781 DO ji = nlci+1, jpi ! added column(s) (full) 782 ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk) 783 ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk) 784 ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk) 785 END DO 786 END DO 787 ! 788 ELSE ! standard close or cyclic treatment 789 ! 790 ! ! East-West boundaries 791 ! !* Cyclic east-west 792 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 793 ptab( 1 ,:,:) = ptab(jpim1,:,:) 794 ptab(jpi,:,:) = ptab( 2 ,:,:) 795 ELSE !* closed 796 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 797 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 798 ENDIF 799 ! ! North-South boundaries (always closed) 800 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 801 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 802 ! 803 ENDIF 804 805 ! 2. East and west directions exchange 806 ! ------------------------------------ 807 ! we play with the neigbours AND the row number because of the periodicity 808 ! 809 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 810 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 811 iihom = nlci-nreci 812 DO jl = 1, jpreci 813 t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 814 t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 815 END DO 816 END SELECT 817 ! 818 ! ! Migrations 819 imigr = jpreci * jpj * jpk 820 ! 821 SELECT CASE ( nbondi ) 822 CASE ( -1 ) 823 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 824 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 825 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 826 CASE ( 0 ) 827 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 828 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 829 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 830 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 831 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 832 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 833 CASE ( 1 ) 834 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 835 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 836 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 837 END SELECT 838 ! 839 ! ! Write Dirichlet lateral conditions 840 iihom = nlci-jpreci 841 ! 842 SELECT CASE ( nbondi ) 843 CASE ( -1 ) 844 DO jl = 1, jpreci 845 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 846 END DO 847 CASE ( 0 ) 848 DO jl = 1, jpreci 849 ptab(jl ,:,:) = t3we(:,jl,:,2) 850 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 851 END DO 852 CASE ( 1 ) 853 DO jl = 1, jpreci 854 ptab(jl ,:,:) = t3we(:,jl,:,2) 855 END DO 856 END SELECT 857 858 859 ! 3. North and south directions 860 ! ----------------------------- 861 ! always closed : we play only with the neigbours 862 ! 863 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 864 ijhom = nlcj-nrecj 865 DO jl = 1, jprecj 866 t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 867 t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 868 END DO 869 ENDIF 870 ! 871 ! ! Migrations 872 imigr = jprecj * jpi * jpk 873 ! 874 SELECT CASE ( nbondj ) 875 CASE ( -1 ) 876 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 877 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 878 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 879 CASE ( 0 ) 880 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 881 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 882 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 883 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 884 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 885 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 886 CASE ( 1 ) 887 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 888 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 889 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 890 END SELECT 891 ! 892 ! ! Write Dirichlet lateral conditions 893 ijhom = nlcj-jprecj 894 ! 895 SELECT CASE ( nbondj ) 896 CASE ( -1 ) 897 DO jl = 1, jprecj 898 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 899 END DO 900 CASE ( 0 ) 901 DO jl = 1, jprecj 902 ptab(:,jl ,:) = t3sn(:,jl,:,2) 903 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 904 END DO 905 CASE ( 1 ) 906 DO jl = 1, jprecj 907 ptab(:,jl,:) = t3sn(:,jl,:,2) 908 END DO 909 END SELECT 910 911 912 ! 4. north fold treatment 913 ! ----------------------- 914 ! 915 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 916 ! 917 SELECT CASE ( jpni ) 918 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 919 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 920 END SELECT 921 ! 922 ENDIF 923 ! 924 END SUBROUTINE mpp_lnk_3d 925 926 927 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 928 !!---------------------------------------------------------------------- 929 !! *** routine mpp_lnk_2d *** 930 !! 931 !! ** Purpose : Message passing manadgement for 2d array 932 !! 933 !! ** Method : Use mppsend and mpprecv function for passing mask 934 !! between processors following neighboring subdomains. 935 !! domain parameters 936 !! nlci : first dimension of the local subdomain 937 !! nlcj : second dimension of the local subdomain 938 !! nbondi : mark for "east-west local boundary" 939 !! nbondj : mark for "north-south local boundary" 940 !! noea : number for local neighboring processors 941 !! nowe : number for local neighboring processors 942 !! noso : number for local neighboring processors 943 !! nono : number for local neighboring processors 944 !! 945 !!---------------------------------------------------------------------- 946 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 947 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 948 ! ! = T , U , V , F , W and I points 949 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 950 ! ! = 1. , the sign is kept 951 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 952 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 953 !! 954 INTEGER :: ji, jj, jl ! dummy loop indices 955 INTEGER :: imigr, iihom, ijhom ! temporary integers 956 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 957 REAL(wp) :: zland 958 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 959 !!---------------------------------------------------------------------- 960 961 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 962 ELSE ; zland = 0.e0 ! zero by default 963 ENDIF 964 965 ! 1. standard boundary treatment 966 ! ------------------------------ 967 ! 968 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 969 ! 970 ! WARNING pt2d is defined only between nld and nle 971 DO jj = nlcj+1, jpj ! added line(s) (inner only) 972 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 973 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) 974 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) 975 END DO 976 DO ji = nlci+1, jpi ! added column(s) (full) 977 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej) 978 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj ) 979 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej) 980 END DO 981 ! 982 ELSE ! standard close or cyclic treatment 983 ! 984 ! ! East-West boundaries 985 IF( nbondi == 2 .AND. & ! Cyclic east-west 986 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 987 pt2d( 1 ,:) = pt2d(jpim1,:) ! west 988 pt2d(jpi,:) = pt2d( 2 ,:) ! east 989 ELSE ! closed 990 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 991 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 992 ENDIF 993 ! ! North-South boundaries (always closed) 994 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point 995 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north 996 ! 997 ENDIF 998 999 ! 2. East and west directions exchange 1000 ! ------------------------------------ 1001 ! we play with the neigbours AND the row number because of the periodicity 1002 ! 1003 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 1004 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1005 iihom = nlci-nreci 1006 DO jl = 1, jpreci 1007 t2ew(:,jl,1) = pt2d(jpreci+jl,:) 1008 t2we(:,jl,1) = pt2d(iihom +jl,:) 1009 END DO 1010 END SELECT 1011 ! 1012 ! ! Migrations 1013 imigr = jpreci * jpj 1014 ! 1015 SELECT CASE ( nbondi ) 1016 CASE ( -1 ) 1017 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 1018 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 1019 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1020 CASE ( 0 ) 1021 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 1022 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 1023 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 1024 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 1025 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1026 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1027 CASE ( 1 ) 1028 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 1029 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 1030 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1031 END SELECT 1032 ! 1033 ! ! Write Dirichlet lateral conditions 1034 iihom = nlci - jpreci 1035 ! 1036 SELECT CASE ( nbondi ) 1037 CASE ( -1 ) 1038 DO jl = 1, jpreci 1039 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1040 END DO 1041 CASE ( 0 ) 1042 DO jl = 1, jpreci 1043 pt2d(jl ,:) = t2we(:,jl,2) 1044 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1045 END DO 1046 CASE ( 1 ) 1047 DO jl = 1, jpreci 1048 pt2d(jl ,:) = t2we(:,jl,2) 1049 END DO 1050 END SELECT 1051 1052 1053 ! 3. North and south directions 1054 ! ----------------------------- 1055 ! always closed : we play only with the neigbours 1056 ! 1057 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1058 ijhom = nlcj-nrecj 1059 DO jl = 1, jprecj 1060 t2sn(:,jl,1) = pt2d(:,ijhom +jl) 1061 t2ns(:,jl,1) = pt2d(:,jprecj+jl) 1062 END DO 1063 ENDIF 1064 ! 1065 ! ! Migrations 1066 imigr = jprecj * jpi 1067 ! 1068 SELECT CASE ( nbondj ) 1069 CASE ( -1 ) 1070 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 1071 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 1072 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1073 CASE ( 0 ) 1074 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 1075 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 1076 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 1077 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 1078 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1079 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1080 CASE ( 1 ) 1081 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 1082 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 1083 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1084 END SELECT 1085 ! 1086 ! ! Write Dirichlet lateral conditions 1087 ijhom = nlcj - jprecj 1088 ! 1089 SELECT CASE ( nbondj ) 1090 CASE ( -1 ) 1091 DO jl = 1, jprecj 1092 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1093 END DO 1094 CASE ( 0 ) 1095 DO jl = 1, jprecj 1096 pt2d(:,jl ) = t2sn(:,jl,2) 1097 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1098 END DO 1099 CASE ( 1 ) 1100 DO jl = 1, jprecj 1101 pt2d(:,jl ) = t2sn(:,jl,2) 1102 END DO 1103 END SELECT 1104 1105 1106 ! 4. north fold treatment 1107 ! ----------------------- 1108 ! 743 1109 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 744 1110 ! … … 1790 2156 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend 1791 2157 REAL(wp), POINTER, DIMENSION(:,:) :: ztab ! temporary workspace 2158 LOGICAL :: lmigr ! is true for those processors that have to migrate the OB 1792 2159 !!---------------------------------------------------------------------- 1793 2160 … … 1815 2182 CALL mppstop 1816 2183 ENDIF 1817 2184 1818 2185 ! Communication level by level 1819 2186 ! ---------------------------- 1820 2187 !!gm Remark : this is very time consumming!!! 1821 2188 ! ! ------------------------ ! 2189 IF( ijpt0 > ijpt1 .OR. iipt0 > iipt1 ) THEN 2190 ! there is nothing to be migrated 2191 lmigr = .FALSE. 2192 ELSE 2193 lmigr = .TRUE. 2194 ENDIF 2195 2196 IF( lmigr ) THEN 2197 1822 2198 DO jk = 1, kk ! Loop over the levels ! 1823 2199 ! ! ------------------------ ! … … 1841 2217 ! --------------------------- 1842 2218 ! 2219 IF( ktype == 1 ) THEN 2220 1843 2221 IF( nbondi /= 2 ) THEN ! Read Dirichlet lateral conditions 1844 2222 iihom = nlci-nreci 1845 DO jl = 1, jpreci 1846 t2ew(:,jl,1) = ztab(jpreci+jl,:) 1847 t2we(:,jl,1) = ztab(iihom +jl,:) 1848 END DO 2223 t2ew(1:jpreci,1,1) = ztab(jpreci+1:nreci, ijpt0) 2224 t2we(1:jpreci,1,1) = ztab(iihom+1:iihom+jpreci, ijpt0) 1849 2225 ENDIF 1850 2226 ! 1851 2227 ! ! Migrations 1852 imigr =jpreci*jpj2228 imigr = jpreci 1853 2229 ! 1854 2230 IF( nbondi == -1 ) THEN … … 1873 2249 ! 1874 2250 IF( nbondi == 0 .OR. nbondi == 1 ) THEN 1875 DO jl = 1, jpreci 1876 ztab(jl,:) = t2we(:,jl,2) 1877 END DO 2251 ztab(1:jpreci, ijpt0) = t2we(1:jpreci,1,2) 1878 2252 ENDIF 1879 2253 IF( nbondi == -1 .OR. nbondi == 0 ) THEN 1880 DO jl = 1, jpreci 1881 ztab(iihom+jl,:) = t2ew(:,jl,2) 1882 END DO 2254 ztab(iihom+1:iihom+jpreci, ijpt0) = t2ew(1:jpreci,1,2) 1883 2255 ENDIF 1884 2256 ENDIF ! (ktype == 1) 1885 2257 1886 2258 ! 2. North and south directions 1887 2259 ! ----------------------------- 1888 2260 ! 2261 IF(ktype == 2 ) THEN 1889 2262 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1890 2263 ijhom = nlcj-nrecj 1891 DO jl = 1, jprecj 1892 t2sn(:,jl,1) = ztab(:,ijhom +jl) 1893 t2ns(:,jl,1) = ztab(:,jprecj+jl) 1894 END DO 2264 t2sn(1:jprecj,1,1) = ztab(iipt0, ijhom+1:ijhom+jprecj) 2265 t2ns(1:jprecj,1,1) = ztab(iipt0, jprecj+1:nrecj) 1895 2266 ENDIF 1896 2267 ! 1897 2268 ! ! Migrations 1898 imigr = jprecj * jpi2269 imigr = jprecj 1899 2270 ! 1900 2271 IF( nbondj == -1 ) THEN … … 1918 2289 ijhom = nlcj - jprecj 1919 2290 IF( nbondj == 0 .OR. nbondj == 1 ) THEN 1920 DO jl = 1, jprecj 1921 ztab(:,jl) = t2sn(:,jl,2) 1922 END DO 2291 ztab(iipt0,1:jprecj) = t2sn(1:jprecj,1,2) 1923 2292 ENDIF 1924 2293 IF( nbondj == 0 .OR. nbondj == -1 ) THEN 1925 DO jl = 1, jprecj 1926 ztab(:,ijhom+jl) = t2ns(:,jl,2) 1927 END DO 2294 ztab(iipt0, ijhom+1:ijhom+jprecj) = t2ns(1:jprecj,1,2) 1928 2295 ENDIF 2296 ENDIF ! (ktype == 2) 1929 2297 IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN 1930 2298 DO jj = ijpt0, ijpt1 ! north/south boundaries 1931 2299 DO ji = iipt0,ilpt1 1932 ptab(ji,jk) = ztab(ji,jj) 2300 ptab(ji,jk) = ztab(ji,jj) 1933 2301 END DO 1934 2302 END DO … … 1936 2304 DO jj = ijpt0, ilpt1 ! east/west boundaries 1937 2305 DO ji = iipt0,iipt1 1938 ptab(jj,jk) = ztab(ji,jj) 2306 ptab(jj,jk) = ztab(ji,jj) 1939 2307 END DO 1940 2308 END DO … … 1943 2311 END DO 1944 2312 ! 2313 ENDIF ! ( lmigr ) 1945 2314 CALL wrk_dealloc( jpi,jpj, ztab ) 1946 2315 ! … … 2539 2908 END SUBROUTINE mpp_lbc_north_e 2540 2909 2910 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2911 !!---------------------------------------------------------------------- 2912 !! *** routine mpp_lnk_bdy_3d *** 2913 !! 2914 !! ** Purpose : Message passing management 2915 !! 2916 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries 2917 !! between processors following neighboring subdomains. 2918 !! domain parameters 2919 !! nlci : first dimension of the local subdomain 2920 !! nlcj : second dimension of the local subdomain 2921 !! nbondi_bdy : mark for "east-west local boundary" 2922 !! nbondj_bdy : mark for "north-south local boundary" 2923 !! noea : number for local neighboring processors 2924 !! nowe : number for local neighboring processors 2925 !! noso : number for local neighboring processors 2926 !! nono : number for local neighboring processors 2927 !! 2928 !! ** Action : ptab with update value at its periphery 2929 !! 2930 !!---------------------------------------------------------------------- 2931 2932 USE lbcnfd ! north fold 2933 2934 INCLUDE 'mpif.h' 2935 2936 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2937 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 2938 ! ! = T , U , V , F , W points 2939 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 2940 ! ! = 1. , the sign is kept 2941 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 2942 INTEGER :: ji, jj, jk, jl ! dummy loop indices 2943 INTEGER :: imigr, iihom, ijhom ! temporary integers 2944 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2945 REAL(wp) :: zland 2946 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 2947 !!---------------------------------------------------------------------- 2948 2949 zland = 0.e0 2950 2951 ! 1. standard boundary treatment 2952 ! ------------------------------ 2953 2954 ! ! East-West boundaries 2955 ! !* Cyclic east-west 2956 2957 IF( nbondi == 2) THEN 2958 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 2959 ptab( 1 ,:,:) = ptab(jpim1,:,:) 2960 ptab(jpi,:,:) = ptab( 2 ,:,:) 2961 ELSE 2962 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 2963 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 2964 ENDIF 2965 ELSEIF(nbondi == -1) THEN 2966 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 2967 ELSEIF(nbondi == 1) THEN 2968 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 2969 ENDIF !* closed 2970 2971 IF (nbondj == 2 .OR. nbondj == -1) THEN 2972 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 2973 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2974 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 2975 ENDIF 2976 2977 ! 2978 2979 ! 2. East and west directions exchange 2980 ! ------------------------------------ 2981 ! we play with the neigbours AND the row number because of the periodicity 2982 ! 2983 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions 2984 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 2985 iihom = nlci-nreci 2986 DO jl = 1, jpreci 2987 t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 2988 t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 2989 END DO 2990 END SELECT 2991 ! 2992 ! ! Migrations 2993 imigr = jpreci * jpj * jpk 2994 ! 2995 SELECT CASE ( nbondi_bdy(ib_bdy) ) 2996 CASE ( -1 ) 2997 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 2998 CASE ( 0 ) 2999 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 3000 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 3001 CASE ( 1 ) 3002 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 3003 END SELECT 3004 ! 3005 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3006 CASE ( -1 ) 3007 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 3008 CASE ( 0 ) 3009 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 3010 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 3011 CASE ( 1 ) 3012 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 3013 END SELECT 3014 ! 3015 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3016 CASE ( -1 ) 3017 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3018 CASE ( 0 ) 3019 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3020 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3021 CASE ( 1 ) 3022 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3023 END SELECT 3024 ! 3025 ! ! Write Dirichlet lateral conditions 3026 iihom = nlci-jpreci 3027 ! 3028 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3029 CASE ( -1 ) 3030 DO jl = 1, jpreci 3031 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 3032 END DO 3033 CASE ( 0 ) 3034 DO jl = 1, jpreci 3035 ptab(jl ,:,:) = t3we(:,jl,:,2) 3036 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 3037 END DO 3038 CASE ( 1 ) 3039 DO jl = 1, jpreci 3040 ptab(jl ,:,:) = t3we(:,jl,:,2) 3041 END DO 3042 END SELECT 3043 3044 3045 ! 3. North and south directions 3046 ! ----------------------------- 3047 ! always closed : we play only with the neigbours 3048 ! 3049 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions 3050 ijhom = nlcj-nrecj 3051 DO jl = 1, jprecj 3052 t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 3053 t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 3054 END DO 3055 ENDIF 3056 ! 3057 ! ! Migrations 3058 imigr = jprecj * jpi * jpk 3059 ! 3060 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3061 CASE ( -1 ) 3062 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 3063 CASE ( 0 ) 3064 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 3065 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 3066 CASE ( 1 ) 3067 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 3068 END SELECT 3069 ! 3070 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3071 CASE ( -1 ) 3072 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 3073 CASE ( 0 ) 3074 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 3075 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 3076 CASE ( 1 ) 3077 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 3078 END SELECT 3079 ! 3080 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3081 CASE ( -1 ) 3082 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3083 CASE ( 0 ) 3084 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3085 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3086 CASE ( 1 ) 3087 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3088 END SELECT 3089 ! 3090 ! ! Write Dirichlet lateral conditions 3091 ijhom = nlcj-jprecj 3092 ! 3093 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3094 CASE ( -1 ) 3095 DO jl = 1, jprecj 3096 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 3097 END DO 3098 CASE ( 0 ) 3099 DO jl = 1, jprecj 3100 ptab(:,jl ,:) = t3sn(:,jl,:,2) 3101 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 3102 END DO 3103 CASE ( 1 ) 3104 DO jl = 1, jprecj 3105 ptab(:,jl,:) = t3sn(:,jl,:,2) 3106 END DO 3107 END SELECT 3108 3109 3110 ! 4. north fold treatment 3111 ! ----------------------- 3112 ! 3113 IF( npolj /= 0) THEN 3114 ! 3115 SELECT CASE ( jpni ) 3116 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 3117 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 3118 END SELECT 3119 ! 3120 ENDIF 3121 ! 3122 END SUBROUTINE mpp_lnk_bdy_3d 3123 3124 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 3125 !!---------------------------------------------------------------------- 3126 !! *** routine mpp_lnk_bdy_2d *** 3127 !! 3128 !! ** Purpose : Message passing management 3129 !! 3130 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries 3131 !! between processors following neighboring subdomains. 3132 !! domain parameters 3133 !! nlci : first dimension of the local subdomain 3134 !! nlcj : second dimension of the local subdomain 3135 !! nbondi_bdy : mark for "east-west local boundary" 3136 !! nbondj_bdy : mark for "north-south local boundary" 3137 !! noea : number for local neighboring processors 3138 !! nowe : number for local neighboring processors 3139 !! noso : number for local neighboring processors 3140 !! nono : number for local neighboring processors 3141 !! 3142 !! ** Action : ptab with update value at its periphery 3143 !! 3144 !!---------------------------------------------------------------------- 3145 3146 USE lbcnfd ! north fold 3147 3148 INCLUDE 'mpif.h' 3149 3150 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3151 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 3152 ! ! = T , U , V , F , W points 3153 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 3154 ! ! = 1. , the sign is kept 3155 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3156 INTEGER :: ji, jj, jl ! dummy loop indices 3157 INTEGER :: imigr, iihom, ijhom ! temporary integers 3158 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3159 REAL(wp) :: zland 3160 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3161 !!---------------------------------------------------------------------- 3162 3163 zland = 0.e0 3164 3165 ! 1. standard boundary treatment 3166 ! ------------------------------ 3167 3168 ! ! East-West boundaries 3169 ! !* Cyclic east-west 3170 3171 IF( nbondi == 2) THEN 3172 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 3173 ptab( 1 ,:) = ptab(jpim1,:) 3174 ptab(jpi,:) = ptab( 2 ,:) 3175 ELSE 3176 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3177 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3178 ENDIF 3179 ELSEIF(nbondi == -1) THEN 3180 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3181 ELSEIF(nbondi == 1) THEN 3182 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3183 ENDIF !* closed 3184 3185 IF (nbondj == 2 .OR. nbondj == -1) THEN 3186 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point 3187 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 3188 ptab(:,nlcj-jprecj+1:jpj) = zland ! north 3189 ENDIF 3190 3191 ! 3192 3193 ! 2. East and west directions exchange 3194 ! ------------------------------------ 3195 ! we play with the neigbours AND the row number because of the periodicity 3196 ! 3197 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions 3198 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 3199 iihom = nlci-nreci 3200 DO jl = 1, jpreci 3201 t2ew(:,jl,1) = ptab(jpreci+jl,:) 3202 t2we(:,jl,1) = ptab(iihom +jl,:) 3203 END DO 3204 END SELECT 3205 ! 3206 ! ! Migrations 3207 imigr = jpreci * jpj 3208 ! 3209 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3210 CASE ( -1 ) 3211 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 3212 CASE ( 0 ) 3213 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 3214 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 3215 CASE ( 1 ) 3216 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 3217 END SELECT 3218 ! 3219 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3220 CASE ( -1 ) 3221 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 3222 CASE ( 0 ) 3223 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 3224 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 3225 CASE ( 1 ) 3226 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 3227 END SELECT 3228 ! 3229 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3230 CASE ( -1 ) 3231 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3232 CASE ( 0 ) 3233 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3234 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3235 CASE ( 1 ) 3236 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3237 END SELECT 3238 ! 3239 ! ! Write Dirichlet lateral conditions 3240 iihom = nlci-jpreci 3241 ! 3242 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3243 CASE ( -1 ) 3244 DO jl = 1, jpreci 3245 ptab(iihom+jl,:) = t2ew(:,jl,2) 3246 END DO 3247 CASE ( 0 ) 3248 DO jl = 1, jpreci 3249 ptab(jl ,:) = t2we(:,jl,2) 3250 ptab(iihom+jl,:) = t2ew(:,jl,2) 3251 END DO 3252 CASE ( 1 ) 3253 DO jl = 1, jpreci 3254 ptab(jl ,:) = t2we(:,jl,2) 3255 END DO 3256 END SELECT 3257 3258 3259 ! 3. North and south directions 3260 ! ----------------------------- 3261 ! always closed : we play only with the neigbours 3262 ! 3263 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions 3264 ijhom = nlcj-nrecj 3265 DO jl = 1, jprecj 3266 t2sn(:,jl,1) = ptab(:,ijhom +jl) 3267 t2ns(:,jl,1) = ptab(:,jprecj+jl) 3268 END DO 3269 ENDIF 3270 ! 3271 ! ! Migrations 3272 imigr = jprecj * jpi 3273 ! 3274 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3275 CASE ( -1 ) 3276 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 3277 CASE ( 0 ) 3278 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 3279 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 3280 CASE ( 1 ) 3281 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 3282 END SELECT 3283 ! 3284 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3285 CASE ( -1 ) 3286 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 3287 CASE ( 0 ) 3288 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 3289 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 3290 CASE ( 1 ) 3291 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 3292 END SELECT 3293 ! 3294 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3295 CASE ( -1 ) 3296 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3297 CASE ( 0 ) 3298 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3299 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3300 CASE ( 1 ) 3301 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3302 END SELECT 3303 ! 3304 ! ! Write Dirichlet lateral conditions 3305 ijhom = nlcj-jprecj 3306 ! 3307 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3308 CASE ( -1 ) 3309 DO jl = 1, jprecj 3310 ptab(:,ijhom+jl) = t2ns(:,jl,2) 3311 END DO 3312 CASE ( 0 ) 3313 DO jl = 1, jprecj 3314 ptab(:,jl ) = t2sn(:,jl,2) 3315 ptab(:,ijhom+jl) = t2ns(:,jl,2) 3316 END DO 3317 CASE ( 1 ) 3318 DO jl = 1, jprecj 3319 ptab(:,jl) = t2sn(:,jl,2) 3320 END DO 3321 END SELECT 3322 3323 3324 ! 4. north fold treatment 3325 ! ----------------------- 3326 ! 3327 IF( npolj /= 0) THEN 3328 ! 3329 SELECT CASE ( jpni ) 3330 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 3331 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 3332 END SELECT 3333 ! 3334 ENDIF 3335 ! 3336 END SUBROUTINE mpp_lnk_bdy_2d 2541 3337 2542 3338 SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
Note: See TracChangeset
for help on using the changeset viewer.