New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 5581 for branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2015-07-10T13:28:53+02:00 (9 years ago)
Author:
timgraham
Message:

Merged head of trunk into branch

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r4785 r5581  
    4242   !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays 
    4343   !!   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) 
    4445   !!   mpprecv         : 
    4546   !!   mppsend       :   SUBROUTINE mpp_ini_znl 
     
    5657   !!   mpp_lbc_north : north fold processors gathering 
    5758   !!   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 
    5860   !!---------------------------------------------------------------------- 
    5961   USE dom_oce        ! ocean space and time domain 
     
    6971   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    7072   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
     73   PUBLIC   mpp_lnk_2d_9  
    7174   PUBLIC   mppscatter, mppgather 
    7275   PUBLIC   mpp_ini_ice, mpp_ini_znl 
     
    7477   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    7578   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    
    7785   !! * Interfaces 
    7886   !! define generic interface for these routine as they are called sometimes 
     
    161169 
    162170 
    163    FUNCTION mynode( ldtxt, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
     171   FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
    164172      !!---------------------------------------------------------------------- 
    165173      !!                  ***  routine mynode  *** 
     
    168176      !!---------------------------------------------------------------------- 
    169177      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
     178      CHARACTER(len=*)             , INTENT(in   ) ::   ldname 
    170179      INTEGER                      , INTENT(in   ) ::   kumnam_ref     ! logical unit for reference namelist 
    171180      INTEGER                      , INTENT(in   ) ::   kumnam_cfg     ! logical unit for configuration namelist 
     
    302311 
    303312      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)       
    306315      ENDIF 
    307316      ! 
     
    515524      ! 
    516525   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 
    517812 
    518813 
     
    29013196   END SUBROUTINE DDPDD_MPI 
    29023197 
     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 
    29033461#else 
    29043462   !!---------------------------------------------------------------------- 
     
    29263484   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 
    29273485   INTEGER :: ncomm_ice 
     3486   INTEGER, PUBLIC            ::   mpi_comm_opa          ! opa local communicator 
    29283487   !!---------------------------------------------------------------------- 
    29293488CONTAINS 
     
    29343493   END FUNCTION lib_mpp_alloc 
    29353494 
    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) 
    29373496      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    29383497      CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
     3498      CHARACTER(len=*) ::   ldname 
    29393499      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 
    29413502      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 ) 
    29433504   END FUNCTION mynode 
    29443505 
Note: See TracChangeset for help on using the changeset viewer.