Changeset 5965 for branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
- Timestamp:
- 2015-12-01T16:35:30+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4645 r5965 42 42 !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays 43 43 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 44 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 44 45 !! mpprecv : 45 46 !! mppsend : SUBROUTINE mpp_ini_znl … … 56 57 !! mpp_lbc_north : north fold processors gathering 57 58 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 59 !! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 58 60 !!---------------------------------------------------------------------- 59 61 USE dom_oce ! ocean space and time domain … … 69 71 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 70 72 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 PUBLIC mpp_lnk_2d_9 71 74 PUBLIC mppscatter, mppgather 72 75 PUBLIC mpp_ini_ice, mpp_ini_znl … … 74 77 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 75 78 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 76 79 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 80 81 TYPE arrayptr 82 REAL , DIMENSION (:,:), POINTER :: pt2d 83 END TYPE arrayptr 84 77 85 !! * Interfaces 78 86 !! define generic interface for these routine as they are called sometimes … … 161 169 162 170 163 FUNCTION mynode( ldtxt, kumnam_ref , kumnam_cfg , kumond , kstop, localComm )171 FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 164 172 !!---------------------------------------------------------------------- 165 173 !! *** routine mynode *** … … 168 176 !!---------------------------------------------------------------------- 169 177 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 178 CHARACTER(len=*) , INTENT(in ) :: ldname 170 179 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 171 180 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist … … 294 303 295 304 IF( mynode == 0 ) THEN 296 CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )297 WRITE(kumond, nammpp)305 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 306 WRITE(kumond, nammpp) 298 307 ENDIF 299 308 ! … … 508 517 END SUBROUTINE mpp_lnk_3d 509 518 519 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 520 !!---------------------------------------------------------------------- 521 !! *** routine mpp_lnk_2d_multiple *** 522 !! 523 !! ** Purpose : Message passing management for multiple 2d arrays 524 !! 525 !! ** Method : Use mppsend and mpprecv function for passing mask 526 !! between processors following neighboring subdomains. 527 !! domain parameters 528 !! nlci : first dimension of the local subdomain 529 !! nlcj : second dimension of the local subdomain 530 !! nbondi : mark for "east-west local boundary" 531 !! nbondj : mark for "north-south local boundary" 532 !! noea : number for local neighboring processors 533 !! nowe : number for local neighboring processors 534 !! noso : number for local neighboring processors 535 !! nono : number for local neighboring processors 536 !! 537 !!---------------------------------------------------------------------- 538 539 INTEGER :: num_fields 540 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 541 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 542 ! ! = T , U , V , F , W and I points 543 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 544 ! ! = 1. , the sign is kept 545 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 546 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 547 !! 548 INTEGER :: ji, jj, jl ! dummy loop indices 549 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 550 INTEGER :: imigr, iihom, ijhom ! temporary integers 551 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 552 553 REAL(wp) :: zland 554 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 555 ! 556 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 557 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 558 559 !!---------------------------------------------------------------------- 560 561 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 562 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 563 564 ! 565 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 566 ELSE ; zland = 0.e0 ! zero by default 567 ENDIF 568 569 ! 1. standard boundary treatment 570 ! ------------------------------ 571 ! 572 !First Array 573 DO ii = 1 , num_fields 574 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 575 ! 576 ! WARNING pt2d is defined only between nld and nle 577 DO jj = nlcj+1, jpj ! added line(s) (inner only) 578 pt2d_array(ii)%pt2d(nldi :nlei , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 579 pt2d_array(ii)%pt2d(1 :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi , nlej) 580 pt2d_array(ii)%pt2d(nlei+1:nlci , jj) = pt2d_array(ii)%pt2d( nlei, nlej) 581 END DO 582 DO ji = nlci+1, jpi ! added column(s) (full) 583 pt2d_array(ii)%pt2d(ji, nldj :nlej ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 584 pt2d_array(ii)%pt2d(ji, 1 :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj ) 585 pt2d_array(ii)%pt2d(ji, nlej+1:jpj ) = pt2d_array(ii)%pt2d(nlei, nlej) 586 END DO 587 ! 588 ELSE ! standard close or cyclic treatment 589 ! 590 ! ! East-West boundaries 591 IF( nbondi == 2 .AND. & ! Cyclic east-west 592 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 593 pt2d_array(ii)%pt2d( 1 , : ) = pt2d_array(ii)%pt2d( jpim1, : ) ! west 594 pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d( 2 , : ) ! east 595 ELSE ! closed 596 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( 1 : jpreci,:) = zland ! south except F-point 597 pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north 598 ENDIF 599 ! ! North-South boundaries (always closed) 600 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d(:, 1:jprecj ) = zland ! south except F-point 601 pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north 602 ! 603 ENDIF 604 END DO 605 606 ! 2. East and west directions exchange 607 ! ------------------------------------ 608 ! we play with the neigbours AND the row number because of the periodicity 609 ! 610 DO ii = 1 , num_fields 611 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 612 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 613 iihom = nlci-nreci 614 DO jl = 1, jpreci 615 zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 616 zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 617 END DO 618 END SELECT 619 END DO 620 ! 621 ! ! Migrations 622 imigr = jpreci * jpj 623 ! 624 SELECT CASE ( nbondi ) 625 CASE ( -1 ) 626 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 627 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 628 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 629 CASE ( 0 ) 630 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 631 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 632 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 633 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 634 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 635 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 636 CASE ( 1 ) 637 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 638 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 639 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 640 END SELECT 641 ! 642 ! ! Write Dirichlet lateral conditions 643 iihom = nlci - jpreci 644 ! 645 646 DO ii = 1 , num_fields 647 SELECT CASE ( nbondi ) 648 CASE ( -1 ) 649 DO jl = 1, jpreci 650 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 651 END DO 652 CASE ( 0 ) 653 DO jl = 1, jpreci 654 pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 655 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 656 END DO 657 CASE ( 1 ) 658 DO jl = 1, jpreci 659 pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 660 END DO 661 END SELECT 662 END DO 663 664 ! 3. North and south directions 665 ! ----------------------------- 666 ! always closed : we play only with the neigbours 667 ! 668 !First Array 669 DO ii = 1 , num_fields 670 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 671 ijhom = nlcj-nrecj 672 DO jl = 1, jprecj 673 zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 674 zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 675 END DO 676 ENDIF 677 END DO 678 ! 679 ! ! Migrations 680 imigr = jprecj * jpi 681 ! 682 SELECT CASE ( nbondj ) 683 CASE ( -1 ) 684 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 685 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 686 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 687 CASE ( 0 ) 688 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 689 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 690 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 691 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 692 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 693 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 694 CASE ( 1 ) 695 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 696 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 697 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 698 END SELECT 699 ! 700 ! ! Write Dirichlet lateral conditions 701 ijhom = nlcj - jprecj 702 ! 703 704 DO ii = 1 , num_fields 705 !First Array 706 SELECT CASE ( nbondj ) 707 CASE ( -1 ) 708 DO jl = 1, jprecj 709 pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 710 END DO 711 CASE ( 0 ) 712 DO jl = 1, jprecj 713 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 714 pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 715 END DO 716 CASE ( 1 ) 717 DO jl = 1, jprecj 718 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 719 END DO 720 END SELECT 721 END DO 722 723 ! 4. north fold treatment 724 ! ----------------------- 725 ! 726 DO ii = 1 , num_fields 727 !First Array 728 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 729 ! 730 SELECT CASE ( jpni ) 731 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 732 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 733 END SELECT 734 ! 735 ENDIF 736 ! 737 END DO 738 739 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 740 ! 741 END SUBROUTINE mpp_lnk_2d_multiple 742 743 744 SUBROUTINE load_array(pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields) 745 !!--------------------------------------------------------------------- 746 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 747 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 748 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 749 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 750 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 751 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 752 INTEGER , INTENT (inout):: num_fields 753 !!--------------------------------------------------------------------- 754 num_fields=num_fields+1 755 pt2d_array(num_fields)%pt2d=>pt2d 756 type_array(num_fields)=cd_type 757 psgn_array(num_fields)=psgn 758 END SUBROUTINE load_array 759 760 761 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 762 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 763 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 764 !!--------------------------------------------------------------------- 765 ! Second 2D array on which the boundary condition is applied 766 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 767 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 768 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 769 ! define the nature of ptab array grid-points 770 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 771 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 772 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 773 ! =-1 the sign change across the north fold boundary 774 REAL(wp) , INTENT(in ) :: psgnA 775 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 776 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 777 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 778 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 779 !! 780 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 781 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 782 ! ! = T , U , V , F , W and I points 783 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 784 INTEGER :: num_fields 785 !!--------------------------------------------------------------------- 786 787 num_fields = 0 788 789 !! Load the first array 790 CALL load_array(pt2dA,cd_typeA,psgnA,pt2d_array, type_array, psgn_array,num_fields) 791 792 !! Look if more arrays are added 793 IF(PRESENT (psgnB) )CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 794 IF(PRESENT (psgnC) )CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 795 IF(PRESENT (psgnD) )CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 796 IF(PRESENT (psgnE) )CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 797 IF(PRESENT (psgnF) )CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 798 IF(PRESENT (psgnG) )CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 799 IF(PRESENT (psgnH) )CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 800 IF(PRESENT (psgnI) )CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 801 802 CALL mpp_lnk_2d_multiple(pt2d_array,type_array,psgn_array,num_fields,cd_mpp,pval) 803 END SUBROUTINE mpp_lnk_2d_9 804 510 805 511 806 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) … … 2026 2321 ijpjm1 = 3 2027 2322 ! 2323 znorthloc(:,:,:) = 0 2028 2324 DO jk = 1, jpk 2029 2325 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d … … 2036 2332 itaille = jpi * jpk * ijpj 2037 2333 2038 2039 2334 IF ( l_north_nogather ) THEN 2040 2335 ! 2041 2336 ztabr(:,:,:) = 0 2337 ztabl(:,:,:) = 0 2338 2042 2339 DO jk = 1, jpk 2043 2340 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2044 2341 ij = jj - nlcj + ijpj 2045 DO ji = 1, nlci2342 DO ji = nfsloop, nfeloop 2046 2343 ztabl(ji,ij,jk) = pt3d(ji,jj,jk) 2047 2344 END DO … … 2050 2347 2051 2348 DO jr = 1,nsndto 2052 IF (isendto(jr) .ne. narea) CALL mppsend( 5, znorthloc, itaille, isendto(jr)-1, ml_req_nf(jr) ) 2349 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2350 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 2351 ENDIF 2053 2352 END DO 2054 2353 DO jr = 1,nsndto 2055 iproc = isendto(jr) 2056 ildi = nldit (iproc) 2057 ilei = nleit (iproc) 2058 iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 2059 IF(isendto(jr) .ne. narea) THEN 2060 CALL mpprecv(5, zfoldwk, itaille, isendto(jr)-1) 2354 iproc = nfipproc(isendto(jr),jpnj) 2355 IF(iproc .ne. -1) THEN 2356 ilei = nleit (iproc+1) 2357 ildi = nldit (iproc+1) 2358 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2359 ENDIF 2360 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 2361 CALL mpprecv(5, zfoldwk, itaille, iproc) 2061 2362 DO jk = 1, jpk 2062 2363 DO jj = 1, ijpj 2063 DO ji = 1, ilei2364 DO ji = ildi, ilei 2064 2365 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) 2065 2366 END DO 2066 2367 END DO 2067 2368 END DO 2068 ELSE 2369 ELSE IF (iproc .eq. (narea-1)) THEN 2069 2370 DO jk = 1, jpk 2070 2371 DO jj = 1, ijpj 2071 DO ji = 1, ilei2372 DO ji = ildi, ilei 2072 2373 ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 2073 2374 END DO … … 2078 2379 IF (l_isend) THEN 2079 2380 DO jr = 1,nsndto 2080 IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2381 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2382 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2383 ENDIF 2081 2384 END DO 2082 2385 ENDIF 2083 2386 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition 2084 !2085 2387 DO jk = 1, jpk 2086 2388 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d … … 2190 2492 ! 2191 2493 ztabr(:,:) = 0 2494 ztabl(:,:) = 0 2495 2192 2496 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2193 2497 ij = jj - nlcj + ijpj 2194 DO ji = 1, nlci2498 DO ji = nfsloop, nfeloop 2195 2499 ztabl(ji,ij) = pt2d(ji,jj) 2196 2500 END DO … … 2198 2502 2199 2503 DO jr = 1,nsndto 2200 IF (isendto(jr) .ne. narea) CALL mppsend(5, znorthloc, itaille, isendto(jr)-1, ml_req_nf(jr)) 2504 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2505 CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) 2506 ENDIF 2201 2507 END DO 2202 2508 DO jr = 1,nsndto 2203 iproc = isendto(jr) 2204 ildi = nldit (iproc) 2205 ilei = nleit (iproc) 2206 iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 2207 IF(isendto(jr) .ne. narea) THEN 2208 CALL mpprecv(5, zfoldwk, itaille, isendto(jr)-1) 2509 iproc = nfipproc(isendto(jr),jpnj) 2510 IF(iproc .ne. -1) THEN 2511 ilei = nleit (iproc+1) 2512 ildi = nldit (iproc+1) 2513 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2514 ENDIF 2515 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 2516 CALL mpprecv(5, zfoldwk, itaille, iproc) 2209 2517 DO jj = 1, ijpj 2210 DO ji = 1, ilei2518 DO ji = ildi, ilei 2211 2519 ztabr(iilb+ji,jj) = zfoldwk(ji,jj) 2212 2520 END DO 2213 2521 END DO 2214 ELSE 2522 ELSE IF (iproc .eq. (narea-1)) THEN 2215 2523 DO jj = 1, ijpj 2216 DO ji = 1, ilei2524 DO ji = ildi, ilei 2217 2525 ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 2218 2526 END DO … … 2222 2530 IF (l_isend) THEN 2223 2531 DO jr = 1,nsndto 2224 IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2532 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2533 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2534 ENDIF 2225 2535 END DO 2226 2536 ENDIF … … 2878 3188 END SUBROUTINE DDPDD_MPI 2879 3189 3190 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 3191 !!--------------------------------------------------------------------- 3192 !! *** routine mpp_lbc_north_icb *** 3193 !! 3194 !! ** Purpose : Ensure proper north fold horizontal bondary condition 3195 !! in mpp configuration in case of jpn1 > 1 and for 2d 3196 !! array with outer extra halo 3197 !! 3198 !! ** Method : North fold condition and mpp with more than one proc 3199 !! in i-direction require a specific treatment. We gather 3200 !! the 4+2*jpr2dj northern lines of the global domain on 1 3201 !! processor and apply lbc north-fold on this sub array. 3202 !! Then we scatter the north fold array back to the processors. 3203 !! This version accounts for an extra halo with icebergs. 3204 !! 3205 !!---------------------------------------------------------------------- 3206 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 3207 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 3208 ! ! = T , U , V , F or W -points 3209 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 3210 !! ! north fold, = 1. otherwise 3211 INTEGER, OPTIONAL , INTENT(in ) :: pr2dj 3212 INTEGER :: ji, jj, jr 3213 INTEGER :: ierr, itaille, ildi, ilei, iilb 3214 INTEGER :: ijpj, ij, iproc, ipr2dj 3215 ! 3216 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 3217 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 3218 3219 !!---------------------------------------------------------------------- 3220 ! 3221 ijpj=4 3222 IF( PRESENT(pr2dj) ) THEN ! use of additional halos 3223 ipr2dj = pr2dj 3224 ELSE 3225 ipr2dj = 0 3226 ENDIF 3227 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 3228 3229 ! 3230 ztab_e(:,:) = 0.e0 3231 3232 ij=0 3233 ! put in znorthloc_e the last 4 jlines of pt2d 3234 DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj 3235 ij = ij + 1 3236 DO ji = 1, jpi 3237 znorthloc_e(ji,ij)=pt2d(ji,jj) 3238 END DO 3239 END DO 3240 ! 3241 itaille = jpi * ( ijpj + 2 * ipr2dj ) 3242 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 3243 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 3244 ! 3245 DO jr = 1, ndim_rank_north ! recover the global north array 3246 iproc = nrank_north(jr) + 1 3247 ildi = nldit (iproc) 3248 ilei = nleit (iproc) 3249 iilb = nimppt(iproc) 3250 DO jj = 1, ijpj+2*ipr2dj 3251 DO ji = ildi, ilei 3252 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 3253 END DO 3254 END DO 3255 END DO 3256 3257 3258 ! 2. North-Fold boundary conditions 3259 ! ---------------------------------- 3260 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 3261 3262 ij = ipr2dj 3263 !! Scatter back to pt2d 3264 DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj 3265 ij = ij +1 3266 DO ji= 1, nlci 3267 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 3268 END DO 3269 END DO 3270 ! 3271 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 3272 ! 3273 END SUBROUTINE mpp_lbc_north_icb 3274 3275 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) 3276 !!---------------------------------------------------------------------- 3277 !! *** routine mpp_lnk_2d_icb *** 3278 !! 3279 !! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs) 3280 !! 3281 !! ** Method : Use mppsend and mpprecv function for passing mask 3282 !! between processors following neighboring subdomains. 3283 !! domain parameters 3284 !! nlci : first dimension of the local subdomain 3285 !! nlcj : second dimension of the local subdomain 3286 !! jpri : number of rows for extra outer halo 3287 !! jprj : number of columns for extra outer halo 3288 !! nbondi : mark for "east-west local boundary" 3289 !! nbondj : mark for "north-south local boundary" 3290 !! noea : number for local neighboring processors 3291 !! nowe : number for local neighboring processors 3292 !! noso : number for local neighboring processors 3293 !! nono : number for local neighboring processors 3294 !! 3295 !!---------------------------------------------------------------------- 3296 INTEGER , INTENT(in ) :: jpri 3297 INTEGER , INTENT(in ) :: jprj 3298 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 3299 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3300 ! ! = T , U , V , F , W and I points 3301 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the 3302 !! ! north boundary, = 1. otherwise 3303 INTEGER :: jl ! dummy loop indices 3304 INTEGER :: imigr, iihom, ijhom ! temporary integers 3305 INTEGER :: ipreci, iprecj ! temporary integers 3306 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3307 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3308 !! 3309 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 3310 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 3311 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 3312 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 3313 !!---------------------------------------------------------------------- 3314 3315 ipreci = jpreci + jpri ! take into account outer extra 2D overlap area 3316 iprecj = jprecj + jprj 3317 3318 3319 ! 1. standard boundary treatment 3320 ! ------------------------------ 3321 ! Order matters Here !!!! 3322 ! 3323 ! ! East-West boundaries 3324 ! !* Cyclic east-west 3325 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 3326 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 3327 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 3328 ! 3329 ELSE !* closed 3330 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point 3331 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north 3332 ENDIF 3333 ! 3334 3335 ! north fold treatment 3336 ! ----------------------- 3337 IF( npolj /= 0 ) THEN 3338 ! 3339 SELECT CASE ( jpni ) 3340 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 3341 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj ) 3342 END SELECT 3343 ! 3344 ENDIF 3345 3346 ! 2. East and west directions exchange 3347 ! ------------------------------------ 3348 ! we play with the neigbours AND the row number because of the periodicity 3349 ! 3350 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 3351 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 3352 iihom = nlci-nreci-jpri 3353 DO jl = 1, ipreci 3354 r2dew(:,jl,1) = pt2d(jpreci+jl,:) 3355 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 3356 END DO 3357 END SELECT 3358 ! 3359 ! ! Migrations 3360 imigr = ipreci * ( jpj + 2*jprj) 3361 ! 3362 SELECT CASE ( nbondi ) 3363 CASE ( -1 ) 3364 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) 3365 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 3366 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3367 CASE ( 0 ) 3368 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 3369 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) 3370 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 3371 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 3372 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3373 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 3374 CASE ( 1 ) 3375 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 3376 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 3377 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3378 END SELECT 3379 ! 3380 ! ! Write Dirichlet lateral conditions 3381 iihom = nlci - jpreci 3382 ! 3383 SELECT CASE ( nbondi ) 3384 CASE ( -1 ) 3385 DO jl = 1, ipreci 3386 pt2d(iihom+jl,:) = r2dew(:,jl,2) 3387 END DO 3388 CASE ( 0 ) 3389 DO jl = 1, ipreci 3390 pt2d(jl-jpri,:) = r2dwe(:,jl,2) 3391 pt2d( iihom+jl,:) = r2dew(:,jl,2) 3392 END DO 3393 CASE ( 1 ) 3394 DO jl = 1, ipreci 3395 pt2d(jl-jpri,:) = r2dwe(:,jl,2) 3396 END DO 3397 END SELECT 3398 3399 3400 ! 3. North and south directions 3401 ! ----------------------------- 3402 ! always closed : we play only with the neigbours 3403 ! 3404 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 3405 ijhom = nlcj-nrecj-jprj 3406 DO jl = 1, iprecj 3407 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 3408 r2dns(:,jl,1) = pt2d(:,jprecj+jl) 3409 END DO 3410 ENDIF 3411 ! 3412 ! ! Migrations 3413 imigr = iprecj * ( jpi + 2*jpri ) 3414 ! 3415 SELECT CASE ( nbondj ) 3416 CASE ( -1 ) 3417 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) 3418 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 3419 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3420 CASE ( 0 ) 3421 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 3422 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) 3423 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 3424 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 3425 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3426 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 3427 CASE ( 1 ) 3428 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 3429 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 3430 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3431 END SELECT 3432 ! 3433 ! ! Write Dirichlet lateral conditions 3434 ijhom = nlcj - jprecj 3435 ! 3436 SELECT CASE ( nbondj ) 3437 CASE ( -1 ) 3438 DO jl = 1, iprecj 3439 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 3440 END DO 3441 CASE ( 0 ) 3442 DO jl = 1, iprecj 3443 pt2d(:,jl-jprj) = r2dsn(:,jl,2) 3444 pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 3445 END DO 3446 CASE ( 1 ) 3447 DO jl = 1, iprecj 3448 pt2d(:,jl-jprj) = r2dsn(:,jl,2) 3449 END DO 3450 END SELECT 3451 3452 END SUBROUTINE mpp_lnk_2d_icb 2880 3453 #else 2881 3454 !!---------------------------------------------------------------------- … … 2903 3476 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 2904 3477 INTEGER :: ncomm_ice 3478 INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator 2905 3479 !!---------------------------------------------------------------------- 2906 3480 CONTAINS … … 2911 3485 END FUNCTION lib_mpp_alloc 2912 3486 2913 FUNCTION mynode( ldtxt, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value)3487 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 2914 3488 INTEGER, OPTIONAL , INTENT(in ) :: localComm 2915 3489 CHARACTER(len=*),DIMENSION(:) :: ldtxt 3490 CHARACTER(len=*) :: ldname 2916 3491 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 2917 IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) ) function_value = 0 3492 IF( PRESENT( localComm ) ) mpi_comm_opa = localComm 3493 function_value = 0 2918 3494 IF( .FALSE. ) ldtxt(:) = 'never done' 2919 CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )3495 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 2920 3496 END FUNCTION mynode 2921 3497
Note: See TracChangeset
for help on using the changeset viewer.
