- Timestamp:
- 2015-07-10T13:28:53+02:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4785 r5581 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 … … 302 311 303 312 IF( mynode == 0 ) THEN 304 CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )305 WRITE(kumond, nammpp)313 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 314 WRITE(kumond, nammpp) 306 315 ENDIF 307 316 ! … … 515 524 ! 516 525 END SUBROUTINE mpp_lnk_3d 526 527 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 528 !!---------------------------------------------------------------------- 529 !! *** routine mpp_lnk_2d_multiple *** 530 !! 531 !! ** Purpose : Message passing management for multiple 2d arrays 532 !! 533 !! ** Method : Use mppsend and mpprecv function for passing mask 534 !! between processors following neighboring subdomains. 535 !! domain parameters 536 !! nlci : first dimension of the local subdomain 537 !! nlcj : second dimension of the local subdomain 538 !! nbondi : mark for "east-west local boundary" 539 !! nbondj : mark for "north-south local boundary" 540 !! noea : number for local neighboring processors 541 !! nowe : number for local neighboring processors 542 !! noso : number for local neighboring processors 543 !! nono : number for local neighboring processors 544 !! 545 !!---------------------------------------------------------------------- 546 547 INTEGER :: num_fields 548 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 549 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 550 ! ! = T , U , V , F , W and I points 551 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 552 ! ! = 1. , the sign is kept 553 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 554 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 555 !! 556 INTEGER :: ji, jj, jl ! dummy loop indices 557 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 558 INTEGER :: imigr, iihom, ijhom ! temporary integers 559 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 560 561 REAL(wp) :: zland 562 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 563 ! 564 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 565 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 566 567 !!---------------------------------------------------------------------- 568 569 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 570 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 571 572 ! 573 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 574 ELSE ; zland = 0.e0 ! zero by default 575 ENDIF 576 577 ! 1. standard boundary treatment 578 ! ------------------------------ 579 ! 580 !First Array 581 DO ii = 1 , num_fields 582 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 583 ! 584 ! WARNING pt2d is defined only between nld and nle 585 DO jj = nlcj+1, jpj ! added line(s) (inner only) 586 pt2d_array(ii)%pt2d(nldi :nlei , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 587 pt2d_array(ii)%pt2d(1 :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi , nlej) 588 pt2d_array(ii)%pt2d(nlei+1:nlci , jj) = pt2d_array(ii)%pt2d( nlei, nlej) 589 END DO 590 DO ji = nlci+1, jpi ! added column(s) (full) 591 pt2d_array(ii)%pt2d(ji, nldj :nlej ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 592 pt2d_array(ii)%pt2d(ji, 1 :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj ) 593 pt2d_array(ii)%pt2d(ji, nlej+1:jpj ) = pt2d_array(ii)%pt2d(nlei, nlej) 594 END DO 595 ! 596 ELSE ! standard close or cyclic treatment 597 ! 598 ! ! East-West boundaries 599 IF( nbondi == 2 .AND. & ! Cyclic east-west 600 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 601 pt2d_array(ii)%pt2d( 1 , : ) = pt2d_array(ii)%pt2d( jpim1, : ) ! west 602 pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d( 2 , : ) ! east 603 ELSE ! closed 604 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( 1 : jpreci,:) = zland ! south except F-point 605 pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north 606 ENDIF 607 ! ! North-South boundaries (always closed) 608 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d(:, 1:jprecj ) = zland ! south except F-point 609 pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north 610 ! 611 ENDIF 612 END DO 613 614 ! 2. East and west directions exchange 615 ! ------------------------------------ 616 ! we play with the neigbours AND the row number because of the periodicity 617 ! 618 DO ii = 1 , num_fields 619 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 620 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 621 iihom = nlci-nreci 622 DO jl = 1, jpreci 623 zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 624 zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 625 END DO 626 END SELECT 627 END DO 628 ! 629 ! ! Migrations 630 imigr = jpreci * jpj 631 ! 632 SELECT CASE ( nbondi ) 633 CASE ( -1 ) 634 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 635 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 636 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 637 CASE ( 0 ) 638 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 639 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 640 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 641 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 642 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 643 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 644 CASE ( 1 ) 645 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 646 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 647 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 648 END SELECT 649 ! 650 ! ! Write Dirichlet lateral conditions 651 iihom = nlci - jpreci 652 ! 653 654 DO ii = 1 , num_fields 655 SELECT CASE ( nbondi ) 656 CASE ( -1 ) 657 DO jl = 1, jpreci 658 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 659 END DO 660 CASE ( 0 ) 661 DO jl = 1, jpreci 662 pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 663 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 664 END DO 665 CASE ( 1 ) 666 DO jl = 1, jpreci 667 pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 668 END DO 669 END SELECT 670 END DO 671 672 ! 3. North and south directions 673 ! ----------------------------- 674 ! always closed : we play only with the neigbours 675 ! 676 !First Array 677 DO ii = 1 , num_fields 678 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 679 ijhom = nlcj-nrecj 680 DO jl = 1, jprecj 681 zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 682 zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 683 END DO 684 ENDIF 685 END DO 686 ! 687 ! ! Migrations 688 imigr = jprecj * jpi 689 ! 690 SELECT CASE ( nbondj ) 691 CASE ( -1 ) 692 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 693 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 694 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 695 CASE ( 0 ) 696 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 697 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 698 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 699 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 700 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 701 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 702 CASE ( 1 ) 703 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 704 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 705 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 706 END SELECT 707 ! 708 ! ! Write Dirichlet lateral conditions 709 ijhom = nlcj - jprecj 710 ! 711 712 DO ii = 1 , num_fields 713 !First Array 714 SELECT CASE ( nbondj ) 715 CASE ( -1 ) 716 DO jl = 1, jprecj 717 pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 718 END DO 719 CASE ( 0 ) 720 DO jl = 1, jprecj 721 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 722 pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 723 END DO 724 CASE ( 1 ) 725 DO jl = 1, jprecj 726 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 727 END DO 728 END SELECT 729 END DO 730 731 ! 4. north fold treatment 732 ! ----------------------- 733 ! 734 DO ii = 1 , num_fields 735 !First Array 736 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 737 ! 738 SELECT CASE ( jpni ) 739 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 740 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 741 END SELECT 742 ! 743 ENDIF 744 ! 745 END DO 746 747 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 748 ! 749 END SUBROUTINE mpp_lnk_2d_multiple 750 751 752 SUBROUTINE load_array(pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields) 753 !!--------------------------------------------------------------------- 754 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 755 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 756 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 757 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 758 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 759 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 760 INTEGER , INTENT (inout):: num_fields 761 !!--------------------------------------------------------------------- 762 num_fields=num_fields+1 763 pt2d_array(num_fields)%pt2d=>pt2d 764 type_array(num_fields)=cd_type 765 psgn_array(num_fields)=psgn 766 END SUBROUTINE load_array 767 768 769 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 770 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 771 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 772 !!--------------------------------------------------------------------- 773 ! Second 2D array on which the boundary condition is applied 774 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 775 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 776 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 777 ! define the nature of ptab array grid-points 778 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 779 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 780 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 781 ! =-1 the sign change across the north fold boundary 782 REAL(wp) , INTENT(in ) :: psgnA 783 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 784 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 785 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 786 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 787 !! 788 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 789 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 790 ! ! = T , U , V , F , W and I points 791 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 792 INTEGER :: num_fields 793 !!--------------------------------------------------------------------- 794 795 num_fields = 0 796 797 !! Load the first array 798 CALL load_array(pt2dA,cd_typeA,psgnA,pt2d_array, type_array, psgn_array,num_fields) 799 800 !! Look if more arrays are added 801 IF(PRESENT (psgnB) )CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 802 IF(PRESENT (psgnC) )CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 803 IF(PRESENT (psgnD) )CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 804 IF(PRESENT (psgnE) )CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 805 IF(PRESENT (psgnF) )CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 806 IF(PRESENT (psgnG) )CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 807 IF(PRESENT (psgnH) )CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 808 IF(PRESENT (psgnI) )CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 809 810 CALL mpp_lnk_2d_multiple(pt2d_array,type_array,psgn_array,num_fields,cd_mpp,pval) 811 END SUBROUTINE mpp_lnk_2d_9 517 812 518 813 … … 2901 3196 END SUBROUTINE DDPDD_MPI 2902 3197 3198 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 3199 !!--------------------------------------------------------------------- 3200 !! *** routine mpp_lbc_north_icb *** 3201 !! 3202 !! ** Purpose : Ensure proper north fold horizontal bondary condition 3203 !! in mpp configuration in case of jpn1 > 1 and for 2d 3204 !! array with outer extra halo 3205 !! 3206 !! ** Method : North fold condition and mpp with more than one proc 3207 !! in i-direction require a specific treatment. We gather 3208 !! the 4+2*jpr2dj northern lines of the global domain on 1 3209 !! processor and apply lbc north-fold on this sub array. 3210 !! Then we scatter the north fold array back to the processors. 3211 !! This version accounts for an extra halo with icebergs. 3212 !! 3213 !!---------------------------------------------------------------------- 3214 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 3215 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 3216 ! ! = T , U , V , F or W -points 3217 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 3218 !! ! north fold, = 1. otherwise 3219 INTEGER, OPTIONAL , INTENT(in ) :: pr2dj 3220 INTEGER :: ji, jj, jr 3221 INTEGER :: ierr, itaille, ildi, ilei, iilb 3222 INTEGER :: ijpj, ij, iproc, ipr2dj 3223 ! 3224 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 3225 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 3226 3227 !!---------------------------------------------------------------------- 3228 ! 3229 ijpj=4 3230 IF( PRESENT(pr2dj) ) THEN ! use of additional halos 3231 ipr2dj = pr2dj 3232 ELSE 3233 ipr2dj = 0 3234 ENDIF 3235 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 3236 3237 ! 3238 ztab_e(:,:) = 0.e0 3239 3240 ij=0 3241 ! put in znorthloc_e the last 4 jlines of pt2d 3242 DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj 3243 ij = ij + 1 3244 DO ji = 1, jpi 3245 znorthloc_e(ji,ij)=pt2d(ji,jj) 3246 END DO 3247 END DO 3248 ! 3249 itaille = jpi * ( ijpj + 2 * ipr2dj ) 3250 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 3251 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 3252 ! 3253 DO jr = 1, ndim_rank_north ! recover the global north array 3254 iproc = nrank_north(jr) + 1 3255 ildi = nldit (iproc) 3256 ilei = nleit (iproc) 3257 iilb = nimppt(iproc) 3258 DO jj = 1, ijpj+2*ipr2dj 3259 DO ji = ildi, ilei 3260 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 3261 END DO 3262 END DO 3263 END DO 3264 3265 3266 ! 2. North-Fold boundary conditions 3267 ! ---------------------------------- 3268 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 3269 3270 ij = ipr2dj 3271 !! Scatter back to pt2d 3272 DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj 3273 ij = ij +1 3274 DO ji= 1, nlci 3275 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 3276 END DO 3277 END DO 3278 ! 3279 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 3280 ! 3281 END SUBROUTINE mpp_lbc_north_icb 3282 3283 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) 3284 !!---------------------------------------------------------------------- 3285 !! *** routine mpp_lnk_2d_icb *** 3286 !! 3287 !! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs) 3288 !! 3289 !! ** Method : Use mppsend and mpprecv function for passing mask 3290 !! between processors following neighboring subdomains. 3291 !! domain parameters 3292 !! nlci : first dimension of the local subdomain 3293 !! nlcj : second dimension of the local subdomain 3294 !! jpri : number of rows for extra outer halo 3295 !! jprj : number of columns for extra outer halo 3296 !! nbondi : mark for "east-west local boundary" 3297 !! nbondj : mark for "north-south local boundary" 3298 !! noea : number for local neighboring processors 3299 !! nowe : number for local neighboring processors 3300 !! noso : number for local neighboring processors 3301 !! nono : number for local neighboring processors 3302 !! 3303 !!---------------------------------------------------------------------- 3304 INTEGER , INTENT(in ) :: jpri 3305 INTEGER , INTENT(in ) :: jprj 3306 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 3307 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3308 ! ! = T , U , V , F , W and I points 3309 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the 3310 !! ! north boundary, = 1. otherwise 3311 INTEGER :: jl ! dummy loop indices 3312 INTEGER :: imigr, iihom, ijhom ! temporary integers 3313 INTEGER :: ipreci, iprecj ! temporary integers 3314 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3315 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3316 !! 3317 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 3318 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 3319 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 3320 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 3321 !!---------------------------------------------------------------------- 3322 3323 ipreci = jpreci + jpri ! take into account outer extra 2D overlap area 3324 iprecj = jprecj + jprj 3325 3326 3327 ! 1. standard boundary treatment 3328 ! ------------------------------ 3329 ! Order matters Here !!!! 3330 ! 3331 ! ! East-West boundaries 3332 ! !* Cyclic east-west 3333 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 3334 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 3335 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 3336 ! 3337 ELSE !* closed 3338 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point 3339 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north 3340 ENDIF 3341 ! 3342 3343 ! north fold treatment 3344 ! ----------------------- 3345 IF( npolj /= 0 ) THEN 3346 ! 3347 SELECT CASE ( jpni ) 3348 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 3349 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj ) 3350 END SELECT 3351 ! 3352 ENDIF 3353 3354 ! 2. East and west directions exchange 3355 ! ------------------------------------ 3356 ! we play with the neigbours AND the row number because of the periodicity 3357 ! 3358 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 3359 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 3360 iihom = nlci-nreci-jpri 3361 DO jl = 1, ipreci 3362 r2dew(:,jl,1) = pt2d(jpreci+jl,:) 3363 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 3364 END DO 3365 END SELECT 3366 ! 3367 ! ! Migrations 3368 imigr = ipreci * ( jpj + 2*jprj) 3369 ! 3370 SELECT CASE ( nbondi ) 3371 CASE ( -1 ) 3372 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) 3373 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 3374 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3375 CASE ( 0 ) 3376 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 3377 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) 3378 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 3379 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 3380 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3381 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 3382 CASE ( 1 ) 3383 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 3384 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 3385 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3386 END SELECT 3387 ! 3388 ! ! Write Dirichlet lateral conditions 3389 iihom = nlci - jpreci 3390 ! 3391 SELECT CASE ( nbondi ) 3392 CASE ( -1 ) 3393 DO jl = 1, ipreci 3394 pt2d(iihom+jl,:) = r2dew(:,jl,2) 3395 END DO 3396 CASE ( 0 ) 3397 DO jl = 1, ipreci 3398 pt2d(jl-jpri,:) = r2dwe(:,jl,2) 3399 pt2d( iihom+jl,:) = r2dew(:,jl,2) 3400 END DO 3401 CASE ( 1 ) 3402 DO jl = 1, ipreci 3403 pt2d(jl-jpri,:) = r2dwe(:,jl,2) 3404 END DO 3405 END SELECT 3406 3407 3408 ! 3. North and south directions 3409 ! ----------------------------- 3410 ! always closed : we play only with the neigbours 3411 ! 3412 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 3413 ijhom = nlcj-nrecj-jprj 3414 DO jl = 1, iprecj 3415 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 3416 r2dns(:,jl,1) = pt2d(:,jprecj+jl) 3417 END DO 3418 ENDIF 3419 ! 3420 ! ! Migrations 3421 imigr = iprecj * ( jpi + 2*jpri ) 3422 ! 3423 SELECT CASE ( nbondj ) 3424 CASE ( -1 ) 3425 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) 3426 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 3427 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3428 CASE ( 0 ) 3429 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 3430 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) 3431 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 3432 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 3433 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3434 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 3435 CASE ( 1 ) 3436 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 3437 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 3438 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3439 END SELECT 3440 ! 3441 ! ! Write Dirichlet lateral conditions 3442 ijhom = nlcj - jprecj 3443 ! 3444 SELECT CASE ( nbondj ) 3445 CASE ( -1 ) 3446 DO jl = 1, iprecj 3447 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 3448 END DO 3449 CASE ( 0 ) 3450 DO jl = 1, iprecj 3451 pt2d(:,jl-jprj) = r2dsn(:,jl,2) 3452 pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 3453 END DO 3454 CASE ( 1 ) 3455 DO jl = 1, iprecj 3456 pt2d(:,jl-jprj) = r2dsn(:,jl,2) 3457 END DO 3458 END SELECT 3459 3460 END SUBROUTINE mpp_lnk_2d_icb 2903 3461 #else 2904 3462 !!---------------------------------------------------------------------- … … 2926 3484 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 2927 3485 INTEGER :: ncomm_ice 3486 INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator 2928 3487 !!---------------------------------------------------------------------- 2929 3488 CONTAINS … … 2934 3493 END FUNCTION lib_mpp_alloc 2935 3494 2936 FUNCTION mynode( ldtxt, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value)3495 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 2937 3496 INTEGER, OPTIONAL , INTENT(in ) :: localComm 2938 3497 CHARACTER(len=*),DIMENSION(:) :: ldtxt 3498 CHARACTER(len=*) :: ldname 2939 3499 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 2940 IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) ) function_value = 0 3500 IF( PRESENT( localComm ) ) mpi_comm_opa = localComm 3501 function_value = 0 2941 3502 IF( .FALSE. ) ldtxt(:) = 'never done' 2942 CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )3503 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 2943 3504 END FUNCTION mynode 2944 3505
Note: See TracChangeset
for help on using the changeset viewer.