Ignore:
Timestamp:
2015-06-19T17:18:00+02:00 (5 years ago)
Author:
davestorkey
Message:

Update 2015/dev_r5021_UKMO1_CICE_coupling branch to revision 5442 of the trunk.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2015/dev_r5021_UKMO1_CICE_coupling/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r5234 r5443  
    7171   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    7272   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
     73   PUBLIC   mpp_lnk_2d_9  
    7374   PUBLIC   mppscatter, mppgather 
    7475   PUBLIC   mpp_ini_ice, mpp_ini_znl 
     
    7879   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    7980 
     81   TYPE arrayptr 
     82      REAL , DIMENSION (:,:),  POINTER :: pt2d 
     83   END TYPE arrayptr 
     84    
    8085   !! * Interfaces 
    8186   !! define generic interface for these routine as they are called sometimes 
     
    164169 
    165170 
    166    FUNCTION mynode( ldtxt, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
     171   FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
    167172      !!---------------------------------------------------------------------- 
    168173      !!                  ***  routine mynode  *** 
     
    171176      !!---------------------------------------------------------------------- 
    172177      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
     178      CHARACTER(len=*)             , INTENT(in   ) ::   ldname 
    173179      INTEGER                      , INTENT(in   ) ::   kumnam_ref     ! logical unit for reference namelist 
    174180      INTEGER                      , INTENT(in   ) ::   kumnam_cfg     ! logical unit for configuration namelist 
     
    297303 
    298304      IF( mynode == 0 ) THEN 
    299         CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    300         WRITE(kumond, nammpp)       
     305         CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
     306         WRITE(kumond, nammpp)       
    301307      ENDIF 
    302308      ! 
     
    510516      ! 
    511517   END SUBROUTINE mpp_lnk_3d 
     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 
    512804 
    513805 
     
    31843476   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 
    31853477   INTEGER :: ncomm_ice 
     3478   INTEGER, PUBLIC            ::   mpi_comm_opa          ! opa local communicator 
    31863479   !!---------------------------------------------------------------------- 
    31873480CONTAINS 
     
    31923485   END FUNCTION lib_mpp_alloc 
    31933486 
    3194    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) 
    31953488      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    31963489      CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
     3490      CHARACTER(len=*) ::   ldname 
    31973491      INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop 
    3198       IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0 
     3492      IF( PRESENT( localComm ) ) mpi_comm_opa = localComm 
     3493      function_value = 0 
    31993494      IF( .FALSE. )   ldtxt(:) = 'never done' 
    3200       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 ) 
    32013496   END FUNCTION mynode 
    32023497 
Note: See TracChangeset for help on using the changeset viewer.