- Timestamp:
- 2012-11-24T14:47:12+01:00 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2012/dev_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r3435 r3646 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 … … 354 359 END FUNCTION mynode 355 360 356 357 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 358 !!---------------------------------------------------------------------- 359 !! *** routine mpp_lnk_3d *** 361 SUBROUTINE mpp_lnk_obc_3d( ptab, cd_type, psgn ) 362 !!---------------------------------------------------------------------- 363 !! *** routine mpp_lnk_obc_3d *** 360 364 !! 361 365 !! ** Purpose : Message passing manadgement 362 366 !! 363 !! ** Method : Use mppsend and mpprecv function for passing mask367 !! ** Method : Use mppsend and mpprecv function for passing OBC boundaries 364 368 !! between processors following neighboring subdomains. 365 369 !! domain parameters … … 381 385 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 382 386 ! ! = 1. , the sign is kept 383 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only384 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)385 387 !! 386 388 INTEGER :: ji, jj, jk, jl ! dummy loop indices … … 391 393 !!---------------------------------------------------------------------- 392 394 393 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 394 ELSE ; zland = 0.e0 ! zero by default 395 ENDIF 395 zland = 0.e0 ! zero by default 396 396 397 397 ! 1. standard boundary treatment 398 398 ! ------------------------------ 399 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 400 ! 401 ! WARNING ptab is defined only between nld and nle 402 DO jk = 1, jpk 403 DO jj = nlcj+1, jpj ! added line(s) (inner only) 404 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 405 ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) 406 ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) 407 END DO 408 DO ji = nlci+1, jpi ! added column(s) (full) 409 ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk) 410 ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk) 411 ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk) 412 END DO 413 END DO 414 ! 415 ELSE ! standard close or cyclic treatment 416 ! 417 ! ! East-West boundaries 418 ! !* Cyclic east-west 419 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 420 ptab( 1 ,:,:) = ptab(jpim1,:,:) 421 ptab(jpi,:,:) = ptab( 2 ,:,:) 422 ELSE !* closed 423 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 424 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 425 ENDIF 426 ! ! North-South boundaries (always closed) 427 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 428 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 429 ! 399 IF( nbondi == 2) THEN 400 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 401 ptab( 1 ,:,:) = ptab(jpim1,:,:) 402 ptab(jpi,:,:) = ptab( 2 ,:,:) 403 ELSE 404 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 405 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 406 ENDIF 407 ELSEIF(nbondi == -1) THEN 408 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 409 ELSEIF(nbondi == 1) THEN 410 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 411 ENDIF !* closed 412 413 IF (nbondj == 2 .OR. nbondj == -1) THEN 414 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 415 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 416 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 430 417 ENDIF 431 418 … … 434 421 ! we play with the neigbours AND the row number because of the periodicity 435 422 ! 423 IF(nbondj .ne. 0) THEN 436 424 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 437 425 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) … … 472 460 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 473 461 END DO 474 CASE ( 0 ) 462 CASE ( 0 ) 475 463 DO jl = 1, jpreci 476 464 ptab(jl ,:,:) = t3we(:,jl,:,2) … … 482 470 END DO 483 471 END SELECT 472 ENDIF 484 473 485 474 … … 488 477 ! always closed : we play only with the neigbours 489 478 ! 479 IF(nbondi .ne. 0) THEN 490 480 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 491 481 ijhom = nlcj-nrecj … … 525 515 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 526 516 END DO 527 CASE ( 0 ) 517 CASE ( 0 ) 528 518 DO jl = 1, jprecj 529 519 ptab(:,jl ,:) = t3sn(:,jl,:,2) … … 535 525 END DO 536 526 END SELECT 527 ENDIF 537 528 538 529 … … 540 531 ! ----------------------- 541 532 ! 542 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp)) THEN533 IF( npolj /= 0 ) THEN 543 534 ! 544 535 SELECT CASE ( jpni ) … … 549 540 ENDIF 550 541 ! 551 END SUBROUTINE mpp_lnk_ 3d552 553 554 SUBROUTINE mpp_lnk_ 2d( pt2d, cd_type, psgn, cd_mpp, pval)555 !!---------------------------------------------------------------------- 556 !! *** routine mpp_lnk_ 2d ***542 END SUBROUTINE mpp_lnk_obc_3d 543 544 545 SUBROUTINE mpp_lnk_obc_2d( pt2d, cd_type, psgn ) 546 !!---------------------------------------------------------------------- 547 !! *** routine mpp_lnk_obc_2d *** 557 548 !! 558 549 !! ** Purpose : Message passing manadgement for 2d array 559 550 !! 560 !! ** Method : Use mppsend and mpprecv function for passing mask551 !! ** Method : Use mppsend and mpprecv function for passing OBC boundaries 561 552 !! between processors following neighboring subdomains. 562 553 !! domain parameters … … 576 567 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 577 568 ! ! = 1. , the sign is kept 578 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only579 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)580 569 !! 581 570 INTEGER :: ji, jj, jl ! dummy loop indices … … 586 575 !!---------------------------------------------------------------------- 587 576 588 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 589 ELSE ; zland = 0.e0 ! zero by default 590 ENDIF 577 zland = 0.e0 ! zero by default 591 578 592 579 ! 1. standard boundary treatment 593 580 ! ------------------------------ 594 581 ! 595 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 596 ! 597 ! WARNING pt2d is defined only between nld and nle 598 DO jj = nlcj+1, jpj ! added line(s) (inner only) 599 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 600 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) 601 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) 602 END DO 603 DO ji = nlci+1, jpi ! added column(s) (full) 604 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej) 605 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj ) 606 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej) 607 END DO 608 ! 609 ELSE ! standard close or cyclic treatment 610 ! 611 ! ! East-West boundaries 612 IF( nbondi == 2 .AND. & ! Cyclic east-west 613 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 614 pt2d( 1 ,:) = pt2d(jpim1,:) ! west 615 pt2d(jpi,:) = pt2d( 2 ,:) ! east 616 ELSE ! closed 617 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 618 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 619 ENDIF 620 ! ! North-South boundaries (always closed) 621 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point 622 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north 623 ! 582 IF( nbondi == 2) THEN 583 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 584 pt2d( 1 ,:) = pt2d(jpim1,:) 585 pt2d(jpi,:) = pt2d( 2 ,:) 586 ELSE 587 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 588 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 589 ENDIF 590 ELSEIF(nbondi == -1) THEN 591 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 592 ELSEIF(nbondi == 1) THEN 593 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 594 ENDIF !* closed 595 596 IF (nbondj == 2 .OR. nbondj == -1) THEN 597 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland ! south except F-point 598 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 599 pt2d(:,nlcj-jprecj+1:jpj) = zland ! north 624 600 ENDIF 625 601 … … 734 710 ! ----------------------- 735 711 ! 712 IF( npolj /= 0 ) THEN 713 ! 714 SELECT CASE ( jpni ) 715 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp 716 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. 717 END SELECT 718 ! 719 ENDIF 720 ! 721 END SUBROUTINE mpp_lnk_obc_2d 722 723 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 724 !!---------------------------------------------------------------------- 725 !! *** routine mpp_lnk_3d *** 726 !! 727 !! ** Purpose : Message passing manadgement 728 !! 729 !! ** Method : Use mppsend and mpprecv function for passing mask 730 !! between processors following neighboring subdomains. 731 !! domain parameters 732 !! nlci : first dimension of the local subdomain 733 !! nlcj : second dimension of the local subdomain 734 !! nbondi : mark for "east-west local boundary" 735 !! nbondj : mark for "north-south local boundary" 736 !! noea : number for local neighboring processors 737 !! nowe : number for local neighboring processors 738 !! noso : number for local neighboring processors 739 !! nono : number for local neighboring processors 740 !! 741 !! ** Action : ptab with update value at its periphery 742 !! 743 !!---------------------------------------------------------------------- 744 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 745 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 746 ! ! = T , U , V , F , W points 747 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 748 ! ! = 1. , the sign is kept 749 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 750 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 751 !! 752 INTEGER :: ji, jj, jk, jl ! dummy loop indices 753 INTEGER :: imigr, iihom, ijhom ! temporary integers 754 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 755 REAL(wp) :: zland 756 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 757 !!---------------------------------------------------------------------- 758 759 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 760 ELSE ; zland = 0.e0 ! zero by default 761 ENDIF 762 763 ! 1. standard boundary treatment 764 ! ------------------------------ 765 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 766 ! 767 ! WARNING ptab is defined only between nld and nle 768 DO jk = 1, jpk 769 DO jj = nlcj+1, jpj ! added line(s) (inner only) 770 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 771 ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) 772 ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) 773 END DO 774 DO ji = nlci+1, jpi ! added column(s) (full) 775 ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk) 776 ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk) 777 ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk) 778 END DO 779 END DO 780 ! 781 ELSE ! standard close or cyclic treatment 782 ! 783 ! ! East-West boundaries 784 ! !* Cyclic east-west 785 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 786 ptab( 1 ,:,:) = ptab(jpim1,:,:) 787 ptab(jpi,:,:) = ptab( 2 ,:,:) 788 ELSE !* closed 789 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 790 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 791 ENDIF 792 ! ! North-South boundaries (always closed) 793 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 794 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 795 ! 796 ENDIF 797 798 ! 2. East and west directions exchange 799 ! ------------------------------------ 800 ! we play with the neigbours AND the row number because of the periodicity 801 ! 802 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 803 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 804 iihom = nlci-nreci 805 DO jl = 1, jpreci 806 t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 807 t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 808 END DO 809 END SELECT 810 ! 811 ! ! Migrations 812 imigr = jpreci * jpj * jpk 813 ! 814 SELECT CASE ( nbondi ) 815 CASE ( -1 ) 816 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 817 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 818 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 819 CASE ( 0 ) 820 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 821 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 822 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 823 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 824 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 825 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 826 CASE ( 1 ) 827 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 828 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 829 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 830 END SELECT 831 ! 832 ! ! Write Dirichlet lateral conditions 833 iihom = nlci-jpreci 834 ! 835 SELECT CASE ( nbondi ) 836 CASE ( -1 ) 837 DO jl = 1, jpreci 838 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 839 END DO 840 CASE ( 0 ) 841 DO jl = 1, jpreci 842 ptab(jl ,:,:) = t3we(:,jl,:,2) 843 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 844 END DO 845 CASE ( 1 ) 846 DO jl = 1, jpreci 847 ptab(jl ,:,:) = t3we(:,jl,:,2) 848 END DO 849 END SELECT 850 851 852 ! 3. North and south directions 853 ! ----------------------------- 854 ! always closed : we play only with the neigbours 855 ! 856 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 857 ijhom = nlcj-nrecj 858 DO jl = 1, jprecj 859 t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 860 t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 861 END DO 862 ENDIF 863 ! 864 ! ! Migrations 865 imigr = jprecj * jpi * jpk 866 ! 867 SELECT CASE ( nbondj ) 868 CASE ( -1 ) 869 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 870 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 871 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 872 CASE ( 0 ) 873 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 874 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 875 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 876 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 877 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 878 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 879 CASE ( 1 ) 880 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 881 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 882 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 883 END SELECT 884 ! 885 ! ! Write Dirichlet lateral conditions 886 ijhom = nlcj-jprecj 887 ! 888 SELECT CASE ( nbondj ) 889 CASE ( -1 ) 890 DO jl = 1, jprecj 891 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 892 END DO 893 CASE ( 0 ) 894 DO jl = 1, jprecj 895 ptab(:,jl ,:) = t3sn(:,jl,:,2) 896 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 897 END DO 898 CASE ( 1 ) 899 DO jl = 1, jprecj 900 ptab(:,jl,:) = t3sn(:,jl,:,2) 901 END DO 902 END SELECT 903 904 905 ! 4. north fold treatment 906 ! ----------------------- 907 ! 908 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 909 ! 910 SELECT CASE ( jpni ) 911 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 912 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 913 END SELECT 914 ! 915 ENDIF 916 ! 917 END SUBROUTINE mpp_lnk_3d 918 919 920 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 921 !!---------------------------------------------------------------------- 922 !! *** routine mpp_lnk_2d *** 923 !! 924 !! ** Purpose : Message passing manadgement for 2d array 925 !! 926 !! ** Method : Use mppsend and mpprecv function for passing mask 927 !! between processors following neighboring subdomains. 928 !! domain parameters 929 !! nlci : first dimension of the local subdomain 930 !! nlcj : second dimension of the local subdomain 931 !! nbondi : mark for "east-west local boundary" 932 !! nbondj : mark for "north-south local boundary" 933 !! noea : number for local neighboring processors 934 !! nowe : number for local neighboring processors 935 !! noso : number for local neighboring processors 936 !! nono : number for local neighboring processors 937 !! 938 !!---------------------------------------------------------------------- 939 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 940 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 941 ! ! = T , U , V , F , W and I points 942 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 943 ! ! = 1. , the sign is kept 944 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 945 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 946 !! 947 INTEGER :: ji, jj, jl ! dummy loop indices 948 INTEGER :: imigr, iihom, ijhom ! temporary integers 949 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 950 REAL(wp) :: zland 951 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 952 !!---------------------------------------------------------------------- 953 954 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 955 ELSE ; zland = 0.e0 ! zero by default 956 ENDIF 957 958 ! 1. standard boundary treatment 959 ! ------------------------------ 960 ! 961 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 962 ! 963 ! WARNING pt2d is defined only between nld and nle 964 DO jj = nlcj+1, jpj ! added line(s) (inner only) 965 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 966 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) 967 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) 968 END DO 969 DO ji = nlci+1, jpi ! added column(s) (full) 970 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej) 971 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj ) 972 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej) 973 END DO 974 ! 975 ELSE ! standard close or cyclic treatment 976 ! 977 ! ! East-West boundaries 978 IF( nbondi == 2 .AND. & ! Cyclic east-west 979 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 980 pt2d( 1 ,:) = pt2d(jpim1,:) ! west 981 pt2d(jpi,:) = pt2d( 2 ,:) ! east 982 ELSE ! closed 983 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 984 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 985 ENDIF 986 ! ! North-South boundaries (always closed) 987 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point 988 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north 989 ! 990 ENDIF 991 992 ! 2. East and west directions exchange 993 ! ------------------------------------ 994 ! we play with the neigbours AND the row number because of the periodicity 995 ! 996 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 997 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 998 iihom = nlci-nreci 999 DO jl = 1, jpreci 1000 t2ew(:,jl,1) = pt2d(jpreci+jl,:) 1001 t2we(:,jl,1) = pt2d(iihom +jl,:) 1002 END DO 1003 END SELECT 1004 ! 1005 ! ! Migrations 1006 imigr = jpreci * jpj 1007 ! 1008 SELECT CASE ( nbondi ) 1009 CASE ( -1 ) 1010 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 1011 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 1012 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1013 CASE ( 0 ) 1014 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 1015 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 1016 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 1017 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 1018 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1019 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1020 CASE ( 1 ) 1021 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 1022 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 1023 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1024 END SELECT 1025 ! 1026 ! ! Write Dirichlet lateral conditions 1027 iihom = nlci - jpreci 1028 ! 1029 SELECT CASE ( nbondi ) 1030 CASE ( -1 ) 1031 DO jl = 1, jpreci 1032 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1033 END DO 1034 CASE ( 0 ) 1035 DO jl = 1, jpreci 1036 pt2d(jl ,:) = t2we(:,jl,2) 1037 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1038 END DO 1039 CASE ( 1 ) 1040 DO jl = 1, jpreci 1041 pt2d(jl ,:) = t2we(:,jl,2) 1042 END DO 1043 END SELECT 1044 1045 1046 ! 3. North and south directions 1047 ! ----------------------------- 1048 ! always closed : we play only with the neigbours 1049 ! 1050 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1051 ijhom = nlcj-nrecj 1052 DO jl = 1, jprecj 1053 t2sn(:,jl,1) = pt2d(:,ijhom +jl) 1054 t2ns(:,jl,1) = pt2d(:,jprecj+jl) 1055 END DO 1056 ENDIF 1057 ! 1058 ! ! Migrations 1059 imigr = jprecj * jpi 1060 ! 1061 SELECT CASE ( nbondj ) 1062 CASE ( -1 ) 1063 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 1064 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 1065 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1066 CASE ( 0 ) 1067 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 1068 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 1069 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 1070 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 1071 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1072 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1073 CASE ( 1 ) 1074 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 1075 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 1076 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1077 END SELECT 1078 ! 1079 ! ! Write Dirichlet lateral conditions 1080 ijhom = nlcj - jprecj 1081 ! 1082 SELECT CASE ( nbondj ) 1083 CASE ( -1 ) 1084 DO jl = 1, jprecj 1085 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1086 END DO 1087 CASE ( 0 ) 1088 DO jl = 1, jprecj 1089 pt2d(:,jl ) = t2sn(:,jl,2) 1090 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1091 END DO 1092 CASE ( 1 ) 1093 DO jl = 1, jprecj 1094 pt2d(:,jl ) = t2sn(:,jl,2) 1095 END DO 1096 END SELECT 1097 1098 1099 ! 4. north fold treatment 1100 ! ----------------------- 1101 ! 736 1102 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 737 1103 ! … … 1781 2147 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend 1782 2148 REAL(wp), POINTER, DIMENSION(:,:) :: ztab ! temporary workspace 2149 LOGICAL :: lmigr ! is true for those processors that have to migrate the OB 1783 2150 !!---------------------------------------------------------------------- 1784 2151 … … 1806 2173 CALL mppstop 1807 2174 ENDIF 1808 2175 1809 2176 ! Communication level by level 1810 2177 ! ---------------------------- 1811 2178 !!gm Remark : this is very time consumming!!! 1812 2179 ! ! ------------------------ ! 2180 IF( ijpt0 > ijpt1 .OR. iipt0 > iipt1 ) THEN 2181 ! there is nothing to be migrated 2182 lmigr = .FALSE. 2183 ELSE 2184 lmigr = .TRUE. 2185 ENDIF 2186 2187 IF( lmigr ) THEN 2188 1813 2189 DO jk = 1, kk ! Loop over the levels ! 1814 2190 ! ! ------------------------ ! … … 1832 2208 ! --------------------------- 1833 2209 ! 2210 IF( ktype == 1 ) THEN 2211 1834 2212 IF( nbondi /= 2 ) THEN ! Read Dirichlet lateral conditions 1835 2213 iihom = nlci-nreci 1836 DO jl = 1, jpreci 1837 t2ew(:,jl,1) = ztab(jpreci+jl,:) 1838 t2we(:,jl,1) = ztab(iihom +jl,:) 1839 END DO 2214 t2ew(1:jpreci,1,1) = ztab(jpreci+1:nreci, ijpt0) 2215 t2we(1:jpreci,1,1) = ztab(iihom+1:iihom+jpreci, ijpt0) 1840 2216 ENDIF 1841 2217 ! 1842 2218 ! ! Migrations 1843 imigr =jpreci*jpj2219 imigr = jpreci 1844 2220 ! 1845 2221 IF( nbondi == -1 ) THEN … … 1864 2240 ! 1865 2241 IF( nbondi == 0 .OR. nbondi == 1 ) THEN 1866 DO jl = 1, jpreci 1867 ztab(jl,:) = t2we(:,jl,2) 1868 END DO 2242 ztab(1:jpreci, ijpt0) = t2we(1:jpreci,1,2) 1869 2243 ENDIF 1870 2244 IF( nbondi == -1 .OR. nbondi == 0 ) THEN 1871 DO jl = 1, jpreci 1872 ztab(iihom+jl,:) = t2ew(:,jl,2) 1873 END DO 2245 ztab(iihom+1:iihom+jpreci, ijpt0) = t2ew(1:jpreci,1,2) 1874 2246 ENDIF 1875 2247 ENDIF ! (ktype == 1) 1876 2248 1877 2249 ! 2. North and south directions 1878 2250 ! ----------------------------- 1879 2251 ! 2252 IF(ktype == 2 ) THEN 1880 2253 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1881 2254 ijhom = nlcj-nrecj 1882 DO jl = 1, jprecj 1883 t2sn(:,jl,1) = ztab(:,ijhom +jl) 1884 t2ns(:,jl,1) = ztab(:,jprecj+jl) 1885 END DO 2255 t2sn(1:jprecj,1,1) = ztab(iipt0, ijhom+1:ijhom+jprecj) 2256 t2ns(1:jprecj,1,1) = ztab(iipt0, jprecj+1:nrecj) 1886 2257 ENDIF 1887 2258 ! 1888 2259 ! ! Migrations 1889 imigr = jprecj * jpi2260 imigr = jprecj 1890 2261 ! 1891 2262 IF( nbondj == -1 ) THEN … … 1909 2280 ijhom = nlcj - jprecj 1910 2281 IF( nbondj == 0 .OR. nbondj == 1 ) THEN 1911 DO jl = 1, jprecj 1912 ztab(:,jl) = t2sn(:,jl,2) 1913 END DO 2282 ztab(iipt0,1:jprecj) = t2sn(1:jprecj,1,2) 1914 2283 ENDIF 1915 2284 IF( nbondj == 0 .OR. nbondj == -1 ) THEN 1916 DO jl = 1, jprecj 1917 ztab(:,ijhom+jl) = t2ns(:,jl,2) 1918 END DO 2285 ztab(iipt0, ijhom+1:ijhom+jprecj) = t2ns(1:jprecj,1,2) 1919 2286 ENDIF 2287 ENDIF ! (ktype == 2) 1920 2288 IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN 1921 2289 DO jj = ijpt0, ijpt1 ! north/south boundaries 1922 2290 DO ji = iipt0,ilpt1 1923 ptab(ji,jk) = ztab(ji,jj) 2291 ptab(ji,jk) = ztab(ji,jj) 1924 2292 END DO 1925 2293 END DO … … 1927 2295 DO jj = ijpt0, ilpt1 ! east/west boundaries 1928 2296 DO ji = iipt0,iipt1 1929 ptab(jj,jk) = ztab(ji,jj) 2297 ptab(jj,jk) = ztab(ji,jj) 1930 2298 END DO 1931 2299 END DO … … 1934 2302 END DO 1935 2303 ! 2304 ENDIF ! ( lmigr ) 1936 2305 CALL wrk_dealloc( jpi,jpj, ztab ) 1937 2306 ! … … 2533 2902 END SUBROUTINE mpp_lbc_north_e 2534 2903 2904 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2905 !!---------------------------------------------------------------------- 2906 !! *** routine mpp_lnk_bdy_3d *** 2907 !! 2908 !! ** Purpose : Message passing management 2909 !! 2910 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries 2911 !! between processors following neighboring subdomains. 2912 !! domain parameters 2913 !! nlci : first dimension of the local subdomain 2914 !! nlcj : second dimension of the local subdomain 2915 !! nbondi_bdy : mark for "east-west local boundary" 2916 !! nbondj_bdy : mark for "north-south local boundary" 2917 !! noea : number for local neighboring processors 2918 !! nowe : number for local neighboring processors 2919 !! noso : number for local neighboring processors 2920 !! nono : number for local neighboring processors 2921 !! 2922 !! ** Action : ptab with update value at its periphery 2923 !! 2924 !!---------------------------------------------------------------------- 2925 2926 USE lbcnfd ! north fold 2927 2928 INCLUDE 'mpif.h' 2929 2930 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2931 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 2932 ! ! = T , U , V , F , W points 2933 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 2934 ! ! = 1. , the sign is kept 2935 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 2936 INTEGER :: ji, jj, jk, jl ! dummy loop indices 2937 INTEGER :: imigr, iihom, ijhom ! temporary integers 2938 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2939 REAL(wp) :: zland 2940 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 2941 !!---------------------------------------------------------------------- 2942 2943 zland = 0.e0 2944 2945 ! 1. standard boundary treatment 2946 ! ------------------------------ 2947 2948 ! ! East-West boundaries 2949 ! !* Cyclic east-west 2950 2951 IF( nbondi == 2) THEN 2952 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 2953 ptab( 1 ,:,:) = ptab(jpim1,:,:) 2954 ptab(jpi,:,:) = ptab( 2 ,:,:) 2955 ELSE 2956 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 2957 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 2958 ENDIF 2959 ELSEIF(nbondi == -1) THEN 2960 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 2961 ELSEIF(nbondi == 1) THEN 2962 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 2963 ENDIF !* closed 2964 2965 IF (nbondj == 2 .OR. nbondj == -1) THEN 2966 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 2967 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2968 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 2969 ENDIF 2970 2971 ! 2972 2973 ! 2. East and west directions exchange 2974 ! ------------------------------------ 2975 ! we play with the neigbours AND the row number because of the periodicity 2976 ! 2977 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions 2978 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 2979 iihom = nlci-nreci 2980 DO jl = 1, jpreci 2981 t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 2982 t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 2983 END DO 2984 END SELECT 2985 ! 2986 ! ! Migrations 2987 imigr = jpreci * jpj * jpk 2988 ! 2989 SELECT CASE ( nbondi_bdy(ib_bdy) ) 2990 CASE ( -1 ) 2991 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 2992 CASE ( 0 ) 2993 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 2994 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 2995 CASE ( 1 ) 2996 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 2997 END SELECT 2998 ! 2999 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3000 CASE ( -1 ) 3001 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 3002 CASE ( 0 ) 3003 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 3004 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 3005 CASE ( 1 ) 3006 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 3007 END SELECT 3008 ! 3009 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3010 CASE ( -1 ) 3011 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3012 CASE ( 0 ) 3013 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3014 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3015 CASE ( 1 ) 3016 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3017 END SELECT 3018 ! 3019 ! ! Write Dirichlet lateral conditions 3020 iihom = nlci-jpreci 3021 ! 3022 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3023 CASE ( -1 ) 3024 DO jl = 1, jpreci 3025 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 3026 END DO 3027 CASE ( 0 ) 3028 DO jl = 1, jpreci 3029 ptab(jl ,:,:) = t3we(:,jl,:,2) 3030 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 3031 END DO 3032 CASE ( 1 ) 3033 DO jl = 1, jpreci 3034 ptab(jl ,:,:) = t3we(:,jl,:,2) 3035 END DO 3036 END SELECT 3037 3038 3039 ! 3. North and south directions 3040 ! ----------------------------- 3041 ! always closed : we play only with the neigbours 3042 ! 3043 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions 3044 ijhom = nlcj-nrecj 3045 DO jl = 1, jprecj 3046 t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 3047 t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 3048 END DO 3049 ENDIF 3050 ! 3051 ! ! Migrations 3052 imigr = jprecj * jpi * jpk 3053 ! 3054 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3055 CASE ( -1 ) 3056 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 3057 CASE ( 0 ) 3058 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 3059 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 3060 CASE ( 1 ) 3061 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 3062 END SELECT 3063 ! 3064 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3065 CASE ( -1 ) 3066 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 3067 CASE ( 0 ) 3068 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 3069 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 3070 CASE ( 1 ) 3071 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 3072 END SELECT 3073 ! 3074 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3075 CASE ( -1 ) 3076 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3077 CASE ( 0 ) 3078 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3079 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3080 CASE ( 1 ) 3081 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3082 END SELECT 3083 ! 3084 ! ! Write Dirichlet lateral conditions 3085 ijhom = nlcj-jprecj 3086 ! 3087 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3088 CASE ( -1 ) 3089 DO jl = 1, jprecj 3090 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 3091 END DO 3092 CASE ( 0 ) 3093 DO jl = 1, jprecj 3094 ptab(:,jl ,:) = t3sn(:,jl,:,2) 3095 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 3096 END DO 3097 CASE ( 1 ) 3098 DO jl = 1, jprecj 3099 ptab(:,jl,:) = t3sn(:,jl,:,2) 3100 END DO 3101 END SELECT 3102 3103 3104 ! 4. north fold treatment 3105 ! ----------------------- 3106 ! 3107 IF( npolj /= 0) THEN 3108 ! 3109 SELECT CASE ( jpni ) 3110 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 3111 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 3112 END SELECT 3113 ! 3114 ENDIF 3115 ! 3116 END SUBROUTINE mpp_lnk_bdy_3d 3117 3118 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 3119 !!---------------------------------------------------------------------- 3120 !! *** routine mpp_lnk_bdy_2d *** 3121 !! 3122 !! ** Purpose : Message passing management 3123 !! 3124 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries 3125 !! between processors following neighboring subdomains. 3126 !! domain parameters 3127 !! nlci : first dimension of the local subdomain 3128 !! nlcj : second dimension of the local subdomain 3129 !! nbondi_bdy : mark for "east-west local boundary" 3130 !! nbondj_bdy : mark for "north-south local boundary" 3131 !! noea : number for local neighboring processors 3132 !! nowe : number for local neighboring processors 3133 !! noso : number for local neighboring processors 3134 !! nono : number for local neighboring processors 3135 !! 3136 !! ** Action : ptab with update value at its periphery 3137 !! 3138 !!---------------------------------------------------------------------- 3139 3140 USE lbcnfd ! north fold 3141 3142 INCLUDE 'mpif.h' 3143 3144 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3145 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 3146 ! ! = T , U , V , F , W points 3147 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 3148 ! ! = 1. , the sign is kept 3149 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3150 INTEGER :: ji, jj, jl ! dummy loop indices 3151 INTEGER :: imigr, iihom, ijhom ! temporary integers 3152 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3153 REAL(wp) :: zland 3154 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3155 !!---------------------------------------------------------------------- 3156 3157 zland = 0.e0 3158 3159 ! 1. standard boundary treatment 3160 ! ------------------------------ 3161 3162 ! ! East-West boundaries 3163 ! !* Cyclic east-west 3164 3165 IF( nbondi == 2) THEN 3166 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 3167 ptab( 1 ,:) = ptab(jpim1,:) 3168 ptab(jpi,:) = ptab( 2 ,:) 3169 ELSE 3170 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3171 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3172 ENDIF 3173 ELSEIF(nbondi == -1) THEN 3174 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3175 ELSEIF(nbondi == 1) THEN 3176 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3177 ENDIF !* closed 3178 3179 IF (nbondj == 2 .OR. nbondj == -1) THEN 3180 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point 3181 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 3182 ptab(:,nlcj-jprecj+1:jpj) = zland ! north 3183 ENDIF 3184 3185 ! 3186 3187 ! 2. East and west directions exchange 3188 ! ------------------------------------ 3189 ! we play with the neigbours AND the row number because of the periodicity 3190 ! 3191 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions 3192 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 3193 iihom = nlci-nreci 3194 DO jl = 1, jpreci 3195 t2ew(:,jl,1) = ptab(jpreci+jl,:) 3196 t2we(:,jl,1) = ptab(iihom +jl,:) 3197 END DO 3198 END SELECT 3199 ! 3200 ! ! Migrations 3201 imigr = jpreci * jpj 3202 ! 3203 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3204 CASE ( -1 ) 3205 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 3206 CASE ( 0 ) 3207 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 3208 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 3209 CASE ( 1 ) 3210 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 3211 END SELECT 3212 ! 3213 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3214 CASE ( -1 ) 3215 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 3216 CASE ( 0 ) 3217 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 3218 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 3219 CASE ( 1 ) 3220 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 3221 END SELECT 3222 ! 3223 SELECT CASE ( nbondi_bdy(ib_bdy) ) 3224 CASE ( -1 ) 3225 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3226 CASE ( 0 ) 3227 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3228 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3229 CASE ( 1 ) 3230 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3231 END SELECT 3232 ! 3233 ! ! Write Dirichlet lateral conditions 3234 iihom = nlci-jpreci 3235 ! 3236 SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 3237 CASE ( -1 ) 3238 DO jl = 1, jpreci 3239 ptab(iihom+jl,:) = t2ew(:,jl,2) 3240 END DO 3241 CASE ( 0 ) 3242 DO jl = 1, jpreci 3243 ptab(jl ,:) = t2we(:,jl,2) 3244 ptab(iihom+jl,:) = t2ew(:,jl,2) 3245 END DO 3246 CASE ( 1 ) 3247 DO jl = 1, jpreci 3248 ptab(jl ,:) = t2we(:,jl,2) 3249 END DO 3250 END SELECT 3251 3252 3253 ! 3. North and south directions 3254 ! ----------------------------- 3255 ! always closed : we play only with the neigbours 3256 ! 3257 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions 3258 ijhom = nlcj-nrecj 3259 DO jl = 1, jprecj 3260 t2sn(:,jl,1) = ptab(:,ijhom +jl) 3261 t2ns(:,jl,1) = ptab(:,jprecj+jl) 3262 END DO 3263 ENDIF 3264 ! 3265 ! ! Migrations 3266 imigr = jprecj * jpi 3267 ! 3268 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3269 CASE ( -1 ) 3270 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 3271 CASE ( 0 ) 3272 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 3273 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 3274 CASE ( 1 ) 3275 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 3276 END SELECT 3277 ! 3278 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3279 CASE ( -1 ) 3280 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 3281 CASE ( 0 ) 3282 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 3283 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 3284 CASE ( 1 ) 3285 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 3286 END SELECT 3287 ! 3288 SELECT CASE ( nbondj_bdy(ib_bdy) ) 3289 CASE ( -1 ) 3290 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3291 CASE ( 0 ) 3292 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3293 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 3294 CASE ( 1 ) 3295 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 3296 END SELECT 3297 ! 3298 ! ! Write Dirichlet lateral conditions 3299 ijhom = nlcj-jprecj 3300 ! 3301 SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 3302 CASE ( -1 ) 3303 DO jl = 1, jprecj 3304 ptab(:,ijhom+jl) = t2ns(:,jl,2) 3305 END DO 3306 CASE ( 0 ) 3307 DO jl = 1, jprecj 3308 ptab(:,jl ) = t2sn(:,jl,2) 3309 ptab(:,ijhom+jl) = t2ns(:,jl,2) 3310 END DO 3311 CASE ( 1 ) 3312 DO jl = 1, jprecj 3313 ptab(:,jl) = t2sn(:,jl,2) 3314 END DO 3315 END SELECT 3316 3317 3318 ! 4. north fold treatment 3319 ! ----------------------- 3320 ! 3321 IF( npolj /= 0) THEN 3322 ! 3323 SELECT CASE ( jpni ) 3324 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 3325 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 3326 END SELECT 3327 ! 3328 ENDIF 3329 ! 3330 END SUBROUTINE mpp_lnk_bdy_2d 2535 3331 2536 3332 SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
Note: See TracChangeset
for help on using the changeset viewer.