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 8586 for branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC – NEMO

Ignore:
Timestamp:
2017-10-04T09:19:23+02:00 (7 years ago)
Author:
gm
Message:

#1911 (ENHANCE-09): PART I.3 - phasing with branch dev_r8183_ICEMODEL revision 8575

Location:
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC
Files:
9 added
4 deleted
52 edited

Legend:

Unmodified
Added
Removed

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ASM/asmbkg.F90

    r8215 r8586  
    3636   USE asmpar             ! Parameters for the assmilation interface 
    3737   USE zdfmxl             ! mixed layer depth 
    38 #if defined key_lim2 
    39    USE ice_2 
    40 #endif 
    4138#if defined key_lim3 
    4239   USE ice 
    … …  
    142139            CALL iom_rstput( kt, nitdin_r, inum, 'sn'     , tsn(:,:,:,jp_sal) ) 
    143140            CALL iom_rstput( kt, nitdin_r, inum, 'sshn'   , sshn              ) 
    144 #if defined key_lim2 || defined key_lim3 
    145             IF( nn_ice == 2  .OR.  nn_ice == 3 ) THEN 
    146                IF( ALLOCATED(frld) ) THEN 
    147                   CALL iom_rstput( kt, nitdin_r, inum, 'iceconc', 1._wp - frld(:,:)   ) 
     141#if defined key_lim3 
     142            IF( nn_ice == 2 ) THEN 
     143               IF( ALLOCATED(at_i) ) THEN 
     144                  CALL iom_rstput( kt, nitdin_r, inum, 'iceconc', at_i(:,:)   ) 
    148145               ELSE 
    149                   CALL ctl_warn('Ice concentration not written to background as ice variable frld not allocated on this timestep') 
     146                  CALL ctl_warn('asm_bkg_wri: Ice concentration not written to background ',   & 
     147                     &          'as ice variable at_i not allocated on this timestep') 
    150148               ENDIF 
    151149            ENDIF 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

    r6140 r8586  
    2222   !!   seaice_asm_inc : Apply the seaice increment 
    2323   !!---------------------------------------------------------------------- 
    24    USE wrk_nemo         ! Memory Allocation 
    25    USE par_oce          ! Ocean space and time domain variables 
    26    USE dom_oce          ! Ocean space and time domain 
    27    USE domvvl           ! domain: variable volume level 
    28    USE oce              ! Dynamics and active tracers defined in memory 
    29    USE ldfdyn           ! lateral diffusion: eddy viscosity coefficients 
    30    USE eosbn2           ! Equation of state - in situ and potential density 
    31    USE zpshde           ! Partial step : Horizontal Derivative 
    32    USE iom              ! Library to read input files 
    33    USE asmpar           ! Parameters for the assmilation interface 
    34    USE c1d              ! 1D initialization 
    35    USE in_out_manager   ! I/O manager 
    36    USE lib_mpp          ! MPP library 
    37 #if defined key_lim2 
    38    USE ice_2            ! LIM2 
    39 #endif 
    40    USE sbc_oce          ! Surface boundary condition variables. 
    41    USE diaobs, ONLY: calc_date     ! Compute the calendar date on a given step 
     24   USE oce             ! Dynamics and active tracers defined in memory 
     25   USE par_oce         ! Ocean space and time domain variables 
     26   USE dom_oce         ! Ocean space and time domain 
     27   USE domvvl          ! domain: variable volume level 
     28   USE ldfdyn          ! lateral diffusion: eddy viscosity coefficients 
     29   USE eosbn2          ! Equation of state - in situ and potential density 
     30   USE zpshde          ! Partial step : Horizontal Derivative 
     31   USE asmpar          ! Parameters for the assmilation interface 
     32   USE c1d             ! 1D initialization 
     33   USE sbc_oce         ! Surface boundary condition variables. 
     34   USE diaobs   , ONLY : calc_date     ! Compute the calendar date on a given step 
     35#if defined key_lim3 
     36   USE ice      , ONLY : hm_i, at_i, at_i_b 
     37#endif 
     38   ! 
     39   USE in_out_manager  ! I/O manager 
     40   USE iom             ! Library to read input files 
     41   USE lib_mpp         ! MPP library 
    4242 
    4343   IMPLICIT NONE 
    … …  
    8686   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   ssh_bkg, ssh_bkginc   ! Background sea surface height and its increment 
    8787   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   seaice_bkginc         ! Increment to the background sea ice conc 
     88#if defined key_cice && defined key_asminc 
     89   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   ndaice_da             ! ice increment tendency into CICE 
     90#endif 
    8891 
    8992   !! * Substitutions 
    … …  
    124127      REAL(wp) :: zdate_inc    ! Time axis in increments file 
    125128      ! 
    126       REAL(wp), POINTER, DIMENSION(:,:) ::   hdiv   ! 2D workspace 
     129      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zhdiv   ! 2D workspace 
    127130      !! 
    128131      NAMELIST/nam_asminc/ ln_bkgwri,                                      & 
    … …  
    170173      ENDIF 
    171174 
    172       nitbkg_r    = nitbkg    + nit000 - 1  ! Background time referenced to nit000 
    173       nitdin_r    = nitdin    + nit000 - 1  ! Background time for DI referenced to nit000 
    174       nitiaustr_r = nitiaustr + nit000 - 1  ! Start of IAU interval referenced to nit000 
    175       nitiaufin_r = nitiaufin + nit000 - 1  ! End of IAU interval referenced to nit000 
    176  
    177       iiauper = nitiaufin_r - nitiaustr_r + 1  ! IAU interval length 
    178       icycper = nitend      - nit000      + 1  ! Cycle interval length 
    179  
    180       ! Date of final time step 
    181       CALL calc_date( nitend, ditend_date ) 
    182  
    183       ! Background time for Jb referenced to ndate0 
    184       CALL calc_date( nitbkg_r, ditbkg_date ) 
    185  
    186       ! Background time for DI referenced to ndate0 
    187       CALL calc_date( nitdin_r, ditdin_date ) 
    188  
    189       ! IAU start time referenced to ndate0 
    190       CALL calc_date( nitiaustr_r, ditiaustr_date ) 
    191  
    192       ! IAU end time referenced to ndate0 
    193       CALL calc_date( nitiaufin_r, ditiaufin_date ) 
     175      nitbkg_r    = nitbkg    + nit000 - 1            ! Background time referenced to nit000 
     176      nitdin_r    = nitdin    + nit000 - 1            ! Background time for DI referenced to nit000 
     177      nitiaustr_r = nitiaustr + nit000 - 1            ! Start of IAU interval referenced to nit000 
     178      nitiaufin_r = nitiaufin + nit000 - 1            ! End of IAU interval referenced to nit000 
     179 
     180      iiauper     = nitiaufin_r - nitiaustr_r + 1     ! IAU interval length 
     181      icycper     = nitend      - nit000      + 1     ! Cycle interval length 
     182 
     183      CALL calc_date( nitend     , ditend_date    )   ! Date of final time step 
     184      CALL calc_date( nitbkg_r   , ditbkg_date    )   ! Background time for Jb referenced to ndate0 
     185      CALL calc_date( nitdin_r   , ditdin_date    )   ! Background time for DI referenced to ndate0 
     186      CALL calc_date( nitiaustr_r, ditiaustr_date )   ! IAU start time referenced to ndate0 
     187      CALL calc_date( nitiaufin_r, ditiaufin_date )   ! IAU end time referenced to ndate0 
    194188 
    195189      IF(lwp) THEN 
    … …  
    263257         ALLOCATE( wgtiau( icycper ) ) 
    264258 
    265          wgtiau(:) = 0.0 
     259         wgtiau(:) = 0._wp 
    266260 
    267261         IF ( niaufn == 0 ) THEN 
    … …  
    339333      ALLOCATE( ssh_iau(jpi,jpj)      ) 
    340334#endif 
    341       t_bkginc(:,:,:) = 0.0 
    342       s_bkginc(:,:,:) = 0.0 
    343       u_bkginc(:,:,:) = 0.0 
    344       v_bkginc(:,:,:) = 0.0 
    345       ssh_bkginc(:,:) = 0.0 
    346       seaice_bkginc(:,:) = 0.0 
     335#if defined key_cice && defined key_asminc 
     336      ALLOCATE( ndaice_da(jpi,jpj)      ) 
     337#endif 
     338      t_bkginc     (:,:,:) = 0._wp 
     339      s_bkginc     (:,:,:) = 0._wp 
     340      u_bkginc     (:,:,:) = 0._wp 
     341      v_bkginc     (:,:,:) = 0._wp 
     342      ssh_bkginc   (:,:)   = 0._wp 
     343      seaice_bkginc(:,:)   = 0._wp 
    347344#if defined key_asminc 
    348       ssh_iau(:,:)    = 0.0 
     345      ssh_iau      (:,:)   = 0._wp 
     346#endif 
     347#if defined key_cice && defined key_asminc 
     348      ndaice_da    (:,:)   = 0._wp 
    349349#endif 
    350350      IF ( ( ln_trainc ).OR.( ln_dyninc ).OR.( ln_sshinc ).OR.( ln_seaiceinc ) ) THEN 
    … …  
    432432      IF ( ln_dyninc .AND. nn_divdmp > 0 ) THEN 
    433433         ! 
    434          CALL wrk_alloc( jpi,jpj,   hdiv )  
     434         ALLOCATE( zhdiv(jpi,jpj) )  
    435435         ! 
    436436         DO jt = 1, nn_divdmp 
    437437            ! 
    438             DO jk = 1, jpkm1           ! hdiv = e1e1 * div 
    439                hdiv(:,:) = 0._wp 
     438            DO jk = 1, jpkm1           ! zhdiv = e1e1 * div 
     439               zhdiv(:,:) = 0._wp 
    440440               DO jj = 2, jpjm1 
    441441                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    442                      hdiv(ji,jj) = (  e2u(ji  ,jj) * e3u_n(ji  ,jj,jk) * u_bkginc(ji  ,jj,jk)    & 
    443                         &           - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * u_bkginc(ji-1,jj,jk)    & 
    444                         &           + e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) * v_bkginc(ji,jj  ,jk)    & 
    445                         &           - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * v_bkginc(ji,jj-1,jk)  ) / e3t_n(ji,jj,jk) 
     442                     zhdiv(ji,jj) = (  e2u(ji  ,jj) * e3u_n(ji  ,jj,jk) * u_bkginc(ji  ,jj,jk)    & 
     443                        &            - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * u_bkginc(ji-1,jj,jk)    & 
     444                        &            + e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) * v_bkginc(ji,jj  ,jk)    & 
     445                        &            - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * v_bkginc(ji,jj-1,jk)  ) / e3t_n(ji,jj,jk) 
    446446                  END DO 
    447447               END DO 
    448                CALL lbc_lnk( hdiv, 'T', 1. )   ! lateral boundary cond. (no sign change) 
     448               CALL lbc_lnk( zhdiv, 'T', 1. )   ! lateral boundary cond. (no sign change) 
    449449               ! 
    450450               DO jj = 2, jpjm1 
    451451                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    452452                     u_bkginc(ji,jj,jk) = u_bkginc(ji,jj,jk)                         & 
    453                         &               + 0.2_wp * ( hdiv(ji+1,jj) - hdiv(ji  ,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) 
     453                        &               + 0.2_wp * ( zhdiv(ji+1,jj) - zhdiv(ji  ,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) 
    454454                     v_bkginc(ji,jj,jk) = v_bkginc(ji,jj,jk)                         & 
    455                         &               + 0.2_wp * ( hdiv(ji,jj+1) - hdiv(ji,jj  ) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk)  
     455                        &               + 0.2_wp * ( zhdiv(ji,jj+1) - zhdiv(ji,jj  ) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk)  
    456456                  END DO 
    457457               END DO 
    … …  
    460460         END DO 
    461461         ! 
    462          CALL wrk_dealloc( jpi,jpj,   hdiv )  
     462         DEALLOCATE( zhdiv )  
    463463         ! 
    464464      ENDIF 
    … …  
    800800      INTEGER  ::   it 
    801801      REAL(wp) ::   zincwgt   ! IAU weight for current time step 
    802 #if defined key_lim2 
     802#if defined key_lim3 
    803803      REAL(wp), DIMENSION(jpi,jpj) ::   zofrld, zohicif, zseaicendg, zhicifinc  ! LIM 
    804804      REAL(wp) ::   zhicifmin = 0.5_wp      ! ice minimum depth in metres 
    … …  
    822822            ENDIF 
    823823            ! 
    824             ! Sea-ice : LIM-3 case (to add) 
    825             ! 
    826 #if defined key_lim2 
    827             ! Sea-ice : LIM-2 case 
    828             zofrld (:,:) = frld(:,:) 
    829             zohicif(:,:) = hicif(:,:) 
    830             ! 
    831             frld  = MIN( MAX( frld (:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 
    832             pfrld = MIN( MAX( pfrld(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 
    833             fr_i(:,:) = 1.0_wp - frld(:,:)        ! adjust ice fraction 
    834             ! 
    835             zseaicendg(:,:) = zofrld(:,:) - frld(:,:)   ! find out actual sea ice nudge applied 
     824            ! Sea-ice : LIM-3 case 
     825            ! 
     826#if defined key_lim3 
     827            zofrld (:,:) = 1._wp - at_i(:,:) 
     828            zohicif(:,:) = hm_i(:,:) 
     829            ! 
     830            at_i  (:,:) = 1. - MIN( MAX( 1.-at_i  (:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 
     831            at_i_b(:,:) = 1. - MIN( MAX( 1.-at_i_b(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 
     832            fr_i(:,:) = at_i(:,:)        ! adjust ice fraction 
     833            ! 
     834            zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:))   ! find out actual sea ice nudge applied 
    836835            ! 
    837836            ! Nudge sea ice depth to bring it up to a required minimum depth 
    838             WHERE( zseaicendg(:,:) > 0.0_wp .AND. hicif(:,:) < zhicifmin )  
    839                zhicifinc(:,:) = (zhicifmin - hicif(:,:)) * zincwgt     
     837            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin )  
     838               zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt     
    840839            ELSEWHERE 
    841840               zhicifinc(:,:) = 0.0_wp 
    … …  
    843842            ! 
    844843            ! nudge ice depth 
    845             hicif (:,:) = hicif (:,:) + zhicifinc(:,:) 
    846             phicif(:,:) = phicif(:,:) + zhicifinc(:,:)        
     844            hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) 
    847845            ! 
    848846            ! seaice salinity balancing (to add) 
    … …  
    873871            neuler = 0                    ! Force Euler forward step 
    874872            ! 
    875             ! Sea-ice : LIM-3 case (to add) 
    876             ! 
    877 #if defined key_lim2 
    878             ! Sea-ice : LIM-2 case. 
    879             zofrld(:,:)=frld(:,:) 
    880             zohicif(:,:)=hicif(:,:) 
     873            ! Sea-ice : LIM-3 case 
     874            ! 
     875#if defined key_lim3 
     876            zofrld (:,:) = 1._wp - at_i(:,:) 
     877            zohicif(:,:) = hm_i(:,:) 
    881878            !  
    882879            ! Initialize the now fields the background + increment 
    883             frld (:,:) = MIN( MAX( frld(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) 
    884             pfrld(:,:) = frld(:,:)  
    885             fr_i (:,:) = 1.0_wp - frld(:,:)                ! adjust ice fraction 
    886             zseaicendg(:,:) = zofrld(:,:) - frld(:,:)      ! find out actual sea ice nudge applied 
     880            at_i(:,:) = 1. - MIN( MAX( 1.-at_i(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) 
     881            at_i_b(:,:) = at_i(:,:)  
     882            fr_i(:,:) = at_i(:,:)        ! adjust ice fraction 
     883            ! 
     884            zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:))   ! find out actual sea ice nudge applied 
    887885            ! 
    888886            ! Nudge sea ice depth to bring it up to a required minimum depth 
    889             WHERE( zseaicendg(:,:) > 0.0_wp .AND. hicif(:,:) < zhicifmin )  
    890                zhicifinc(:,:) = (zhicifmin - hicif(:,:)) * zincwgt     
     887            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin )  
     888               zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt     
    891889            ELSEWHERE 
    892                zhicifinc(:,:) = 0._wp 
     890               zhicifinc(:,:) = 0.0_wp 
    893891            END WHERE 
    894892            ! 
    895893            ! nudge ice depth 
    896             hicif (:,:) = hicif (:,:) + zhicifinc(:,:) 
    897             phicif(:,:) = phicif(:,:)        
     894            hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) 
    898895            ! 
    899896            ! seaice salinity balancing (to add) 
    … …  
    917914         ENDIF 
    918915 
    919 !#if defined defined key_lim2 || defined key_cice 
     916!#if defined defined key_lim3 || defined key_cice 
    920917! 
    921918!            IF (ln_seaicebal ) THEN        

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_oce.F90

    r7753 r8586  
    5555      REAL(wp), POINTER, DIMENSION(:,:) ::  tem 
    5656      REAL(wp), POINTER, DIMENSION(:,:) ::  sal 
    57 #if defined key_lim2 
    58       LOGICAL                           ::   ll_frld 
    59       LOGICAL                           ::   ll_hicif 
    60       LOGICAL                           ::   ll_hsnif 
    61       REAL(wp), POINTER, DIMENSION(:)   ::   frld 
    62       REAL(wp), POINTER, DIMENSION(:)   ::   hicif 
    63       REAL(wp), POINTER, DIMENSION(:)   ::   hsnif 
    64 #elif defined key_lim3 
     57#if defined key_lim3 
    6558      LOGICAL                           ::   ll_a_i 
    66       LOGICAL                           ::   ll_ht_i 
    67       LOGICAL                           ::   ll_ht_s 
     59      LOGICAL                           ::   ll_h_i 
     60      LOGICAL                           ::   ll_h_s 
    6861      REAL(wp), POINTER, DIMENSION(:,:) ::   a_i    !: now ice leads fraction climatology 
    69       REAL(wp), POINTER, DIMENSION(:,:) ::   ht_i   !: Now ice  thickness climatology 
    70       REAL(wp), POINTER, DIMENSION(:,:) ::   ht_s   !: now snow thickness 
     62      REAL(wp), POINTER, DIMENSION(:,:) ::   h_i    !: Now ice  thickness climatology 
     63      REAL(wp), POINTER, DIMENSION(:,:) ::   h_s    !: now snow thickness 
    7164#endif 
    7265#if defined key_top 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r7861 r8586  
    1313   !!            3.6  !  2012-01  (C. Rousset) add ice boundary conditions for lim3 
    1414   !!---------------------------------------------------------------------- 
    15    !!    bdy_dta        : read external data along open boundaries from file 
    16    !!    bdy_dta_init   : initialise arrays etc for reading of external data 
     15 
    1716   !!---------------------------------------------------------------------- 
    18    USE timing          ! Timing 
    19    USE oce             ! ocean dynamics and tracers 
    20    USE dom_oce         ! ocean space and time domain 
    21    USE phycst          ! physical constants 
    22    USE bdy_oce         ! ocean open boundary conditions   
    23    USE bdytides        ! tidal forcing at boundaries 
    24    USE fldread         ! read input fields 
    25    USE iom             ! IOM library 
    26    USE in_out_manager  ! I/O logical units 
    27 #if defined key_lim2 
    28    USE ice_2 
    29 #elif defined key_lim3 
    30    USE ice 
    31    USE limvar          ! redistribute ice input into categories 
    32 #endif 
    33    USE sbcapr 
    34    USE sbctide         ! Tidal forcing or not 
     17   !!    bdy_dta      : read external data along open boundaries from file 
     18   !!    bdy_dta_init : initialise arrays etc for reading of external data 
     19   !!---------------------------------------------------------------------- 
     20   USE oce            ! ocean dynamics and tracers 
     21   USE dom_oce        ! ocean space and time domain 
     22   USE phycst         ! physical constants 
     23   USE sbcapr         ! atmospheric pressure forcing 
     24   USE sbctide        ! Tidal forcing or not 
     25   USE bdy_oce        ! ocean open boundary conditions   
     26   USE bdytides       ! tidal forcing at boundaries 
     27#if defined key_lim3 
     28   USE ice            ! sea-ice variables 
     29   USE icevar         ! redistribute ice input into categories 
     30#endif 
     31   ! 
     32   USE fldread        ! read input fields 
     33   USE iom            ! IOM library 
     34   USE in_out_manager ! I/O logical units 
     35   USE timing         ! Timing 
    3536 
    3637   IMPLICIT NONE 
    … …  
    5051 
    5152#if defined key_lim3 
    52    LOGICAL :: ll_bdylim3                  ! determine whether ice input is lim2 (F) or lim3 (T) type 
     53   LOGICAL :: ll_bdylim3                  ! determine whether ice input is 1cat (F) or Xcat (T) type 
    5354   INTEGER :: jfld_hti, jfld_hts, jfld_ai ! indices of ice thickness, snow thickness and concentration in bf structure 
    5455#endif 
    … …  
    176177            ENDIF 
    177178 
    178 #if defined key_lim2 
    179             IF( nn_ice_lim_dta(ib_bdy) == 0 ) THEN  
    180                ilen1(:) = nblen(:) 
    181                IF( dta%ll_frld ) THEN 
    182                   igrd = 1  
    183                   DO ib = 1, ilen1(igrd) 
    184                      ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    185                      ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    186                      dta_bdy(ib_bdy)%frld(ib) = frld(ii,ij) * tmask(ii,ij,1)          
    187                   END DO  
    188                END IF 
    189                IF( dta%ll_hicif ) THEN 
    190                   igrd = 1  
    191                   DO ib = 1, ilen1(igrd) 
    192                      ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    193                      ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    194                      dta_bdy(ib_bdy)%hicif(ib) = hicif(ii,ij) * tmask(ii,ij,1)          
    195                   END DO  
    196                END IF 
    197                IF( dta%ll_hsnif ) THEN 
    198                   igrd = 1  
    199                   DO ib = 1, ilen1(igrd) 
    200                      ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    201                      ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    202                      dta_bdy(ib_bdy)%hsnif(ib) = hsnif(ii,ij) * tmask(ii,ij,1)          
    203                   END DO  
    204                END IF 
    205             ENDIF 
    206 #elif defined key_lim3 
     179#if defined key_lim3 
    207180            IF( nn_ice_lim_dta(ib_bdy) == 0 ) THEN  
    208181               ilen1(:) = nblen(:) 
    … …  
    217190                  END DO 
    218191               ENDIF 
    219                IF( dta%ll_ht_i ) THEN 
     192               IF( dta%ll_h_i ) THEN 
    220193                  igrd = 1    
    221194                  DO jl = 1, jpl 
    … …  
    223196                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    224197                        ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    225                         dta_bdy(ib_bdy)%ht_i (ib,jl) =  ht_i(ii,ij,jl) * tmask(ii,ij,1)  
     198                        dta_bdy(ib_bdy)%h_i (ib,jl) =  h_i(ii,ij,jl) * tmask(ii,ij,1)  
    226199                     END DO 
    227200                  END DO 
    228201               ENDIF 
    229                IF( dta%ll_ht_s ) THEN 
     202               IF( dta%ll_h_s ) THEN 
    230203                  igrd = 1    
    231204                  DO jl = 1, jpl 
    … …  
    233206                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    234207                        ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    235                         dta_bdy(ib_bdy)%ht_s (ib,jl) =  ht_s(ii,ij,jl) * tmask(ii,ij,1)  
     208                        dta_bdy(ib_bdy)%h_s (ib,jl) =  h_s(ii,ij,jl) * tmask(ii,ij,1)  
    236209                     END DO 
    237210                  END DO 
    … …  
    373346               ENDIF 
    374347#if defined key_lim3 
    375                IF( .NOT. ll_bdylim3 .AND. cn_ice_lim(ib_bdy) /= 'none' .AND. nn_ice_lim_dta(ib_bdy) == 1 ) THEN ! bdy ice input (case input is lim2 type) 
    376                 CALL lim_var_itd ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 
    377                                   & dta_bdy(ib_bdy)%ht_i,     dta_bdy(ib_bdy)%ht_s,     dta_bdy(ib_bdy)%a_i     ) 
     348               IF( .NOT. ll_bdylim3 .AND. cn_ice_lim(ib_bdy) /= 'none' .AND. nn_ice_lim_dta(ib_bdy) == 1 ) THEN ! bdy ice input (case input is 1cat) 
     349                CALL ice_var_itd ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 
     350                                  & dta_bdy(ib_bdy)%h_i,     dta_bdy(ib_bdy)%h_s,     dta_bdy(ib_bdy)%a_i     ) 
    378351               ENDIF 
    379352#endif 
    … …  
    449422      TYPE(FLD_N) ::   bn_tem, bn_sal, bn_u3d, bn_v3d   !  
    450423      TYPE(FLD_N) ::   bn_ssh, bn_u2d, bn_v2d           ! informations about the fields to be read 
    451 #if defined key_lim2 
    452       TYPE(FLD_N) ::   bn_frld, bn_hicif, bn_hsnif      ! 
    453 #elif defined key_lim3 
    454       TYPE(FLD_N) ::   bn_a_i, bn_ht_i, bn_ht_s       
     424#if defined key_lim3 
     425      TYPE(FLD_N) ::   bn_a_i, bn_h_i, bn_h_s       
    455426#endif 
    456427      NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d  
    457 #if defined key_lim2 
    458       NAMELIST/nambdy_dta/ bn_frld, bn_hicif, bn_hsnif 
    459 #elif defined key_lim3 
    460       NAMELIST/nambdy_dta/ bn_a_i, bn_ht_i, bn_ht_s 
     428#if defined key_lim3 
     429      NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s 
    461430#endif 
    462431      NAMELIST/nambdy_dta/ ln_full_vel, nb_jpk_bdy 
    … …  
    475444                               ,nn_dyn3d_dta(ib_bdy)       & 
    476445                               ,nn_tra_dta(ib_bdy)         & 
    477 #if ( defined key_lim2 || defined key_lim3 ) 
     446#if defined key_lim3 
    478447                              ,nn_ice_lim_dta(ib_bdy)    & 
    479448#endif 
    … …  
    496465            nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 2 
    497466         ENDIF 
    498 #if ( defined key_lim2 || defined key_lim3 ) 
     467#if defined key_lim3 
    499468         IF( cn_ice_lim(ib_bdy) /= 'none' .and. nn_ice_lim_dta(ib_bdy) == 1  ) THEN 
    500469            nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 3 
    … …  
    637606            ENDIF 
    638607 
    639 #if defined key_lim2 
     608#if defined key_lim3 
    640609            ! sea ice 
    641610            IF( nn_ice_lim_dta(ib_bdy) == 1 ) THEN 
    642  
    643                IF( dta%ll_frld ) THEN 
    644                   jfld = jfld + 1 
    645                   blf_i(jfld) = bn_frld 
    646                   ibdy(jfld) = ib_bdy 
    647                   igrid(jfld) = 1 
    648                   ilen1(jfld) = nblen(igrid(jfld)) 
    649                   ilen3(jfld) = 1 
    650                ENDIF 
    651  
    652                IF( dta%ll_hicif ) THEN 
    653                   jfld = jfld + 1 
    654                   blf_i(jfld) = bn_hicif 
    655                   ibdy(jfld) = ib_bdy 
    656                   igrid(jfld) = 1 
    657                   ilen1(jfld) = nblen(igrid(jfld)) 
    658                   ilen3(jfld) = 1 
    659                ENDIF 
    660  
    661                IF( dta%ll_hsnif ) THEN 
    662                   jfld = jfld + 1 
    663                   blf_i(jfld) = bn_hsnif 
    664                   ibdy(jfld) = ib_bdy 
    665                   igrid(jfld) = 1 
    666                   ilen1(jfld) = nblen(igrid(jfld)) 
    667                   ilen3(jfld) = 1 
    668                ENDIF 
    669  
    670             ENDIF 
    671 #elif defined key_lim3 
    672             ! sea ice 
    673             IF( nn_ice_lim_dta(ib_bdy) == 1 ) THEN 
    674                ! Test for types of ice input (lim2 or lim3)  
     611               ! Test for types of ice input (1cat or Xcat)  
    675612               ! Build file name to find dimensions  
    676613               clname=TRIM( cn_dir )//TRIM(bn_a_i%clname) 
    … …  
    689626 
    690627                IF ( zndims == 4 ) THEN 
    691                  ll_bdylim3 = .TRUE.   ! lim3 input 
     628                 ll_bdylim3 = .TRUE.   ! Xcat input 
    692629               ELSE 
    693                  ll_bdylim3 = .FALSE.  ! lim2 input       
     630                 ll_bdylim3 = .FALSE.  ! 1cat input       
    694631               ENDIF 
    695632               ! End test 
    … …  
    704641               ENDIF 
    705642 
    706                IF( dta%ll_ht_i ) THEN 
    707                   jfld = jfld + 1 
    708                   blf_i(jfld) = bn_ht_i 
     643               IF( dta%ll_h_i ) THEN 
     644                  jfld = jfld + 1 
     645                  blf_i(jfld) = bn_h_i 
    709646                  ibdy(jfld) = ib_bdy 
    710647                  igrid(jfld) = 1 
    … …  
    713650               ENDIF 
    714651 
    715                IF( dta%ll_ht_s ) THEN 
    716                   jfld = jfld + 1 
    717                    blf_i(jfld) = bn_ht_s 
     652               IF( dta%ll_h_s ) THEN 
     653                  jfld = jfld + 1 
     654                   blf_i(jfld) = bn_h_s 
    718655                  ibdy(jfld) = ib_bdy 
    719656                  igrid(jfld) = 1 
    … …  
    848785         ENDIF 
    849786 
    850 #if defined key_lim2 
     787#if defined key_lim3 
    851788         IF (cn_ice_lim(ib_bdy) /= 'none') THEN 
    852789            IF( nn_ice_lim_dta(ib_bdy) == 0 ) THEN 
    853                ALLOCATE( dta_bdy(ib_bdy)%frld(nblen(1)) ) 
    854                ALLOCATE( dta_bdy(ib_bdy)%hicif(nblen(1)) ) 
    855                ALLOCATE( dta_bdy(ib_bdy)%hsnif(nblen(1)) ) 
     790               ALLOCATE( dta_bdy(ib_bdy)%a_i(nblen(1),jpl) ) 
     791               ALLOCATE( dta_bdy(ib_bdy)%h_i(nblen(1),jpl) ) 
     792               ALLOCATE( dta_bdy(ib_bdy)%h_s(nblen(1),jpl) ) 
    856793            ELSE 
    857                jfld = jfld + 1 
    858                dta_bdy(ib_bdy)%frld  => bf(jfld)%fnow(:,1,1) 
    859                jfld = jfld + 1 
    860                dta_bdy(ib_bdy)%hicif => bf(jfld)%fnow(:,1,1) 
    861                jfld = jfld + 1 
    862                dta_bdy(ib_bdy)%hsnif => bf(jfld)%fnow(:,1,1) 
    863             ENDIF 
    864          ENDIF 
    865 #elif defined key_lim3 
    866          IF (cn_ice_lim(ib_bdy) /= 'none') THEN 
    867             IF( nn_ice_lim_dta(ib_bdy) == 0 ) THEN 
    868                ALLOCATE( dta_bdy(ib_bdy)%a_i (nblen(1),jpl) ) 
    869                ALLOCATE( dta_bdy(ib_bdy)%ht_i(nblen(1),jpl) ) 
    870                ALLOCATE( dta_bdy(ib_bdy)%ht_s(nblen(1),jpl) ) 
    871             ELSE 
    872                IF ( ll_bdylim3 ) THEN ! case input is lim3 type 
    873                   jfld = jfld + 1 
    874                   dta_bdy(ib_bdy)%a_i  => bf(jfld)%fnow(:,1,:) 
    875                   jfld = jfld + 1 
    876                   dta_bdy(ib_bdy)%ht_i => bf(jfld)%fnow(:,1,:) 
    877                   jfld = jfld + 1 
    878                   dta_bdy(ib_bdy)%ht_s => bf(jfld)%fnow(:,1,:) 
    879                ELSE ! case input is lim2 type 
     794               IF ( ll_bdylim3 ) THEN ! case input is Xcat 
     795                  jfld = jfld + 1 
     796                  dta_bdy(ib_bdy)%a_i => bf(jfld)%fnow(:,1,:) 
     797                  jfld = jfld + 1 
     798                  dta_bdy(ib_bdy)%h_i => bf(jfld)%fnow(:,1,:) 
     799                  jfld = jfld + 1 
     800                  dta_bdy(ib_bdy)%h_s => bf(jfld)%fnow(:,1,:) 
     801               ELSE ! case input is 1cat 
    880802                  jfld_ai  = jfld + 1 
    881803                  jfld_hti = jfld + 2 
    882804                  jfld_hts = jfld + 3 
    883805                  jfld     = jfld + 3 
    884                   ALLOCATE( dta_bdy(ib_bdy)%a_i (nblen(1),jpl) ) 
    885                   ALLOCATE( dta_bdy(ib_bdy)%ht_i(nblen(1),jpl) ) 
    886                   ALLOCATE( dta_bdy(ib_bdy)%ht_s(nblen(1),jpl) ) 
    887                   dta_bdy(ib_bdy)%a_i (:,:) = 0._wp 
    888                   dta_bdy(ib_bdy)%ht_i(:,:) = 0._wp 
    889                   dta_bdy(ib_bdy)%ht_s(:,:) = 0._wp 
     806                  ALLOCATE( dta_bdy(ib_bdy)%a_i(nblen(1),jpl) ) 
     807                  ALLOCATE( dta_bdy(ib_bdy)%h_i(nblen(1),jpl) ) 
     808                  ALLOCATE( dta_bdy(ib_bdy)%h_s(nblen(1),jpl) ) 
     809                  dta_bdy(ib_bdy)%a_i(:,:) = 0._wp 
     810                  dta_bdy(ib_bdy)%h_i(:,:) = 0._wp 
     811                  dta_bdy(ib_bdy)%h_s(:,:) = 0._wp 
    890812               ENDIF 
    891813 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r7646 r8586  
    2929   USE lib_mpp        ! for mpp_sum   
    3030   USE iom            ! I/O 
    31    USE wrk_nemo       ! Memory Allocation 
    3231   USE timing         ! Timing 
    3332 
    … …  
    117116      ! 
    118117   END SUBROUTINE bdy_init 
    119     
     118 
     119 
    120120   SUBROUTINE bdy_segs 
    121121      !!---------------------------------------------------------------------- 
    … …  
    129129      !! ** Input   :  bdy_init.nc, input file for unstructured open boundaries 
    130130      !!----------------------------------------------------------------------       
    131  
    132       ! local variables 
    133       !------------------- 
    134131      INTEGER  ::   ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 
    135132      INTEGER  ::   icount, icountr, ibr_max, ilen1, ibm1  ! local integers 
    … …  
    151148      INTEGER :: com_east_b, com_west_b, com_south_b, com_north_b  ! Flags for boundaries receiving 
    152149      INTEGER :: iw_b(4), ie_b(4), is_b(4), in_b(4)                ! Arrays for neighbours coordinates 
    153       REAL(wp), POINTER, DIMENSION(:,:)      ::   zfmask  ! temporary fmask array excluding coastal boundary condition (shlat) 
     150      REAL(wp), TARGET, DIMENSION(jpi,jpj) ::   zfmask  ! temporary fmask array excluding coastal boundary condition (shlat) 
    154151      !! 
    155152      CHARACTER(LEN=1)                     ::   ctypebdy   !     -        -  
    … …  
    351348        IF(lwp) WRITE(numout,*) 
    352349 
    353 #if defined key_lim2 
    354         IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice:  ' 
    355         SELECT CASE( cn_ice_lim(ib_bdy) )                   
    356           CASE('none') 
     350#if defined key_lim3 
     351         IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice:  ' 
     352         SELECT CASE( cn_ice_lim(ib_bdy) )                   
     353         CASE('none') 
    357354             IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    358              dta_bdy(ib_bdy)%ll_frld = .false. 
    359              dta_bdy(ib_bdy)%ll_hicif = .false. 
    360              dta_bdy(ib_bdy)%ll_hsnif = .false. 
    361           CASE('frs') 
     355             dta_bdy(ib_bdy)%ll_a_i = .false. 
     356             dta_bdy(ib_bdy)%ll_h_i = .false. 
     357             dta_bdy(ib_bdy)%ll_h_s = .false. 
     358         CASE('frs') 
    362359             IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    363              dta_bdy(ib_bdy)%ll_frld  = .true. 
    364              dta_bdy(ib_bdy)%ll_hicif = .true. 
    365              dta_bdy(ib_bdy)%ll_hsnif = .true. 
    366           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) 
    367         END SELECT 
    368         IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN  
    369            SELECT CASE( nn_ice_lim_dta(ib_bdy) )                   !  
    370               CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'         
    371               CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
    372               CASE DEFAULT   ;   CALL ctl_stop( 'nn_ice_lim_dta must be 0 or 1' ) 
    373            END SELECT 
    374         ENDIF 
    375         IF(lwp) WRITE(numout,*) 
    376 #elif defined key_lim3 
    377         IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice:  ' 
    378         SELECT CASE( cn_ice_lim(ib_bdy) )                   
    379           CASE('none') 
    380              IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    381              dta_bdy(ib_bdy)%ll_a_i  = .false. 
    382              dta_bdy(ib_bdy)%ll_ht_i = .false. 
    383              dta_bdy(ib_bdy)%ll_ht_s = .false. 
    384           CASE('frs') 
    385              IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    386              dta_bdy(ib_bdy)%ll_a_i  = .true. 
    387              dta_bdy(ib_bdy)%ll_ht_i = .true. 
    388              dta_bdy(ib_bdy)%ll_ht_s = .true. 
    389           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) 
    390         END SELECT 
     360             dta_bdy(ib_bdy)%ll_a_i = .true. 
     361             dta_bdy(ib_bdy)%ll_h_i = .true. 
     362             dta_bdy(ib_bdy)%ll_h_s = .true. 
     363         CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) 
     364         END SELECT 
    391365        IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN  
    392366           SELECT CASE( nn_ice_lim_dta(ib_bdy) )                   !  
    … …  
    404378        IF(lwp) WRITE(numout,*) '      Width of relaxation zone = ', nn_rimwidth(ib_bdy) 
    405379        IF(lwp) WRITE(numout,*) 
    406  
    407       ENDDO 
    408  
    409      IF (nb_bdy .gt. 0) THEN 
     380         ! 
     381      END DO 
     382 
     383     IF( nb_bdy > 0 ) THEN 
    410384        IF( ln_vol ) THEN                     ! check volume conservation (nn_volctl value) 
    411385          IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries' 
    … …  
    919893                  IF( nbrdta(ib,igrd,ib_bdy) == 1 )   icountr = icountr+1 
    920894               ENDIF 
    921             ENDDO 
     895            END DO 
    922896            idx_bdy(ib_bdy)%nblenrim(igrd) = icountr !: length of rim boundary data on each proc 
    923897            idx_bdy(ib_bdy)%nblen   (igrd) = icount  !: length of boundary data on each proc         
    924          ENDDO  ! igrd 
     898         END DO  ! igrd 
    925899 
    926900         ! Allocate index arrays for this boundary set 
    927901         !-------------------------------------------- 
    928902         ilen1 = MAXVAL( idx_bdy(ib_bdy)%nblen(:) ) 
    929          ALLOCATE( idx_bdy(ib_bdy)%nbi   (ilen1,jpbgrd) ) 
    930          ALLOCATE( idx_bdy(ib_bdy)%nbj   (ilen1,jpbgrd) ) 
    931          ALLOCATE( idx_bdy(ib_bdy)%nbr   (ilen1,jpbgrd) ) 
    932          ALLOCATE( idx_bdy(ib_bdy)%nbd   (ilen1,jpbgrd) ) 
    933          ALLOCATE( idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) ) 
    934          ALLOCATE( idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) ) 
    935          ALLOCATE( idx_bdy(ib_bdy)%nbw   (ilen1,jpbgrd) ) 
    936          ALLOCATE( idx_bdy(ib_bdy)%flagu (ilen1,jpbgrd) ) 
    937          ALLOCATE( idx_bdy(ib_bdy)%flagv (ilen1,jpbgrd) ) 
     903         ALLOCATE( idx_bdy(ib_bdy)%nbi   (ilen1,jpbgrd) ,   & 
     904            &      idx_bdy(ib_bdy)%nbj   (ilen1,jpbgrd) ,   & 
     905            &      idx_bdy(ib_bdy)%nbr   (ilen1,jpbgrd) ,   & 
     906            &      idx_bdy(ib_bdy)%nbd   (ilen1,jpbgrd) ,   & 
     907            &      idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) ,   & 
     908            &      idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) ,   & 
     909            &      idx_bdy(ib_bdy)%nbw   (ilen1,jpbgrd) ,   & 
     910            &      idx_bdy(ib_bdy)%flagu (ilen1,jpbgrd) ,   & 
     911            &      idx_bdy(ib_bdy)%flagv (ilen1,jpbgrd) ) 
    938912 
    939913         ! Dispatch mapping indices and discrete distances on each processor 
    … …  
    11481122         END DO  
    11491123 
    1150       ENDDO 
     1124      END DO 
    11511125 
    11521126      ! ------------------------------------------------------ 
    … …  
    12121186        DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    12131187          bdyvmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 
    1214         ENDDO 
    1215       ENDDO 
     1188        END DO 
     1189      END DO 
    12161190 
    12171191      ! For the flagu/flagv calculation below we require a version of fmask without 
    12181192      ! the land boundary condition (shlat) included: 
    1219       CALL wrk_alloc(jpi,jpj,  zfmask )  
    12201193      DO ij = 2, jpjm1 
    12211194         DO ii = 2, jpim1 
    … …  
    12411214         ! flagu =  1 : u is normal to the boundary and is direction is inward 
    12421215   
    1243          DO igrd = 1,jpbgrd  
     1216         DO igrd = 1, jpbgrd  
    12441217            SELECT CASE( igrd ) 
    12451218               CASE( 1 )   ;   pmask => umask   (:,:,1)   ;   i_offset = 0 
    … …  
    13461319      IF( nb_bdy>0 )   DEALLOCATE( nbidta, nbjdta, nbrdta ) 
    13471320      ! 
    1348       CALL wrk_dealloc(jpi,jpj,   zfmask )  
    1349       ! 
    13501321      IF( nn_timing == 1 )   CALL timing_stop('bdy_segs') 
    13511322      ! 
    13521323   END SUBROUTINE bdy_segs 
     1324 
    13531325 
    13541326   SUBROUTINE bdy_ctl_seg 
    … …  
    17271699   END SUBROUTINE bdy_ctl_seg 
    17281700 
     1701 
    17291702   SUBROUTINE bdy_ctl_corn( ib1, ib2 ) 
    17301703      !!---------------------------------------------------------------------- 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90

    r8215 r8586  
    228228 
    229229 
    230       ALLOCATE( un_crs(jpi_crs,jpj_crs,jpk) , vn_crs(jpi_crs,jpj_crs,jpk)  ,     & 
    231          &      wn_crs(jpi_crs,jpj_crs,jpk) , hdivn_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(11)) 
     230      ALLOCATE( un_crs(jpi_crs,jpj_crs,jpk) , vn_crs   (jpi_crs,jpj_crs,jpk) ,     & 
     231         &      wn_crs(jpi_crs,jpj_crs,jpk) , hdivn_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(11)) 
    232232 
    233233     ALLOCATE( sshn_crs(jpi_crs,jpj_crs), emp_crs (jpi_crs,jpj_crs), emp_b_crs(jpi_crs,jpj_crs), & 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90

    r8215 r8586  
    2525   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2626   USE timing          ! preformance summary 
    27    USE wrk_nemo        ! working array 
    2827 
    2928   IMPLICIT NONE 
    … …  
    6059      REAL(wp) ::   zztmp             !   -      - 
    6160      ! 
    62       REAL(wp), POINTER, DIMENSION(:,:,:) ::   ze3t, ze3u, ze3v, ze3w   ! 3D workspace for e3 
    63       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zt, zt_crs, z3d 
    64       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zs, zs_crs   
     61      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze3t, ze3u, ze3v, ze3w   ! 3D workspace for e3 
     62      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zt  , zs  , z3d 
     63      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) ::   zt_crs, zs_crs   
    6564      !!---------------------------------------------------------------------- 
    6665      !  
    6766      IF( nn_timing == 1 )   CALL timing_start('crs_fld') 
    68  
    69       !  Initialize arrays 
    70       CALL wrk_alloc( jpi,jpj,jpk,   ze3t, ze3w ) 
    71       CALL wrk_alloc( jpi,jpj,jpk,   ze3u, ze3v ) 
    72       CALL wrk_alloc( jpi,jpj,jpk,   zt  , zs  , z3d ) 
    73       ! 
    74       CALL wrk_alloc( jpi_crs,jpj_crs,jpk,   zt_crs, zs_crs ) 
    7567 
    7668      ! Depth work arrrays 
    … …  
    248240      CALL iom_put( "ice_cover", fr_i_crs )   ! ice cover output  
    249241 
    250       !  free memory 
    251       CALL wrk_dealloc( jpi,jpj,jpk,   ze3t, ze3w ) 
    252       CALL wrk_dealloc( jpi,jpj,jpk,   ze3u, ze3v ) 
    253       CALL wrk_dealloc( jpi,jpj,jpk,   zt  , zs   ) 
    254       CALL wrk_dealloc( jpi_crs,jpj_crs,jpk,   zt_crs, zs_crs ) 
    255242      ! 
    256243      CALL iom_swap( "nemo" )     ! return back on high-resolution grid 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90

    r6140 r8586  
    1515    
    1616   INTERFACE crs_lbc_lnk 
    17       MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_3d_gather, crs_lbc_lnk_2d 
     17      MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_2d 
    1818   END INTERFACE 
    1919    
    … …  
    4949      ll_grid_crs = ( jpi == jpi_crs ) 
    5050      ! 
    51       IF( PRESENT(pval) ) THEN  ;  zval = pval 
    52       ELSE                      ;  zval = 0._wp 
     51      IF( PRESENT(pval) ) THEN   ;   zval = pval 
     52      ELSE                       ;   zval = 0._wp 
    5353      ENDIF 
    5454      ! 
    5555      IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    5656      ! 
    57       IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp, pval=zval  ) 
    58       ELSE                         ; CALL lbc_lnk( pt3d1, cd_type1, psgn, pval=zval  ) 
     57      IF( PRESENT( cd_mpp ) ) THEN   ;  CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp, pval=zval  ) 
     58      ELSE                           ;   CALL lbc_lnk( pt3d1, cd_type1, psgn        , pval=zval  ) 
    5959      ENDIF 
    6060      ! 
    … …  
    6262      ! 
    6363   END SUBROUTINE crs_lbc_lnk_3d 
    64     
    65     
    66    SUBROUTINE crs_lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 
    67       !!--------------------------------------------------------------------- 
    68       !!                  ***  SUBROUTINE crs_lbc_lnk  *** 
    69       !! 
    70       !! ** Purpose :   set lateral boundary conditions for coarsened grid 
    71       !! 
    72       !! ** Method  :   Swap domain indices from full to coarse domain 
    73       !!                before arguments are passed directly to lbc_lnk. 
    74       !!                Upon exiting, switch back to full domain indices. 
    75       !!---------------------------------------------------------------------- 
    76       CHARACTER(len=1)                        , INTENT(in   ) ::   cd_type1, cd_type2 ! grid type 
    77       REAL(wp)                                , INTENT(in   ) ::   psgn               ! control of the sign 
    78       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) ::   pt3d1   , pt3d2    ! 3D array on which the lbc is applied 
    79       ! 
    80       LOGICAL ::   ll_grid_crs 
    81       !!---------------------------------------------------------------------- 
    82       ! 
    83       ll_grid_crs = ( jpi == jpi_crs ) 
    84       ! 
    85       IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    86       ! 
    87       CALL lbc_lnk( pt3d1, cd_type1, pt3d2, cd_type2, psgn  ) 
    88       ! 
    89       IF( .NOT.ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain 
    90       ! 
    91    END SUBROUTINE crs_lbc_lnk_3d_gather 
    92  
    9364    
    9465    
    … …  
    11586      ll_grid_crs = ( jpi == jpi_crs ) 
    11687      ! 
    117       IF( PRESENT(pval) ) THEN  ;  zval = pval 
    118       ELSE                      ;  zval = 0._wp 
     88      IF( PRESENT(pval) ) THEN   ;   zval = pval 
     89      ELSE                       ;   zval = 0._wp 
    11990      ENDIF 
    12091      ! 
    12192      IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    12293      ! 
    123       IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval  ) 
    124       ELSE                         ; CALL lbc_lnk( pt2d, cd_type, psgn, pval=zval  ) 
     94      IF( PRESENT( cd_mpp ) ) THEN   ;  CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval  ) 
     95      ELSE                           ;   CALL lbc_lnk( pt2d, cd_type, psgn        , pval=zval  ) 
    12596      ENDIF 
    12697      ! 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DIA/dia25h.F90

    r8215 r8586  
    1010   USE zdf_oce         ! ocean vertical physics     
    1111   USE zdfgls   , ONLY : hmxl_n 
     12   ! 
    1213   USE in_out_manager  ! I/O units 
    1314   USE iom             ! I/0 library 
    14    USE wrk_nemo        ! work arrays 
    1515 
    1616   IMPLICIT NONE 
    … …  
    110110         rmxln_25h(:,:,:) = hmxl_n(:,:,:) 
    111111      ENDIF 
    112 #if defined key_lim3 || defined key_lim2 
     112#if defined key_lim3 
    113113         CALL ctl_stop('STOP', 'dia_25h not setup yet to do tidemean ice') 
    114114#endif  

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DIA/diadct.F90

    r7646 r8586  
    3232   USE dianam          ! build name of file 
    3333   USE lib_mpp         ! distributed memory computing library 
    34 #if defined key_lim2 
    35    USE ice_2 
    36 #endif 
    3734#if defined key_lim3 
    3835   USE ice 
    … …  
    240237           !debug this section computing ? 
    241238           lldebug=.FALSE. 
    242            IF( (jsec==nn_secdebug .OR. nn_secdebug==-1) .AND.  kt==nit000+nn_dct-1 .AND. lwp ) lldebug=.TRUE.  
     239           IF( (jsec==nn_secdebug .OR. nn_secdebug==-1) .AND.  kt==nit000+nn_dct-1 ) lldebug=.TRUE.  
    243240 
    244241           !Compute transport through section   
    … …  
    249246        IF( MOD(kt,nn_dctwri)==0 )THEN 
    250247 
    251            IF( lwp .AND. kt==nit000+nn_dctwri-1 )WRITE(numout,*)"      diadct: average transports and write at kt = ",kt          
     248           IF( kt==nit000+nn_dctwri-1 )WRITE(numout,*)"      diadct: average transports and write at kt = ",kt          
    252249   
    253250           !! divide arrays by nn_dctwri/nn_dct to obtain average  
    … …  
    335332     DO jsec=1,nb_sec_max      !loop on the nb_sec sections 
    336333 
    337         IF ( lwp .AND. ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) ) & 
     334        IF (  jsec==nn_secdebug .OR. nn_secdebug==-1 ) & 
    338335           & WRITE(numout,*)'debuging for section number: ',jsec  
    339336 
    … …  
    355352        IF( jsec .NE. isec )  CALL ctl_stop( cltmp ) 
    356353 
    357         IF( lwp .AND. ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) )WRITE(numout,*)"isec ",isec  
     354        IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )WRITE(numout,*)"isec ",isec  
    358355 
    359356        READ(numdct_in)secs(jsec)%name 
    … …  
    374371        !----- 
    375372 
    376         IF( lwp .AND. ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) )THEN 
     373        IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN 
    377374           
    378375            WRITE(clformat,'(a,i2,a)') '(A40,', nb_class_max,'(f8.3,1X))'  
    … …  
    407404           !debug 
    408405           !----- 
    409            IF( lwp .AND. ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) )THEN 
     406           IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN 
    410407              WRITE(numout,*)"      List of points in global domain:" 
    411408              DO jpt=1,iptglo 
    … …  
    441438           !debug 
    442439           !----- 
    443            IF(   lwp .AND. ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) )THEN 
     440           IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN 
    444441              WRITE(numout,*)"      List of points selected by the proc:" 
    445442              DO jpt = 1,iptloc 
    … …  
    459456           !remove redundant points between processors 
    460457           !------------------------------------------ 
    461            lldebug = .FALSE. ; IF ( (jsec==nn_secdebug .OR. nn_secdebug==-1) .AND. lwp ) lldebug = .TRUE. 
     458           lldebug = .FALSE. ; IF ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) lldebug = .TRUE. 
    462459           IF( iptloc .NE. 0 )THEN 
    463460              CALL removepoints(secs(jsec),'I','top_list',lldebug) 
    … …  
    475472           !debug 
    476473           !----- 
    477            IF( lwp .AND. ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) )THEN 
     474           IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN 
    478475              WRITE(numout,*)"      List of points after removepoints:" 
    479476              iptloc = secs(jsec)%nb_point 
    … …  
    487484 
    488485        ELSE  ! iptglo = 0 
    489            IF( lwp .AND. ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) )& 
     486           IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )& 
    490487              WRITE(numout,*)'   No points for this section.' 
    491488        ENDIF 
    … …  
    695692            !     LOOP ON THE LEVEL     |  
    696693            !---------------------------|  
    697             DO jk = 1, mbathy(k%I,k%J)            !Sum of the transport on the vertical 
     694            DO jk = 1, mbkt(k%I,k%J)            !Sum of the transport on the vertical 
    698695            !           ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point  
    699696            SELECT CASE( sec%direction(jseg) ) 
    … …  
    747744           END DO !end of loop on the level 
    748745 
    749 #if defined key_lim2 || defined key_lim3 
     746#if defined key_lim3 
    750747 
    751748           !ICE CASE     
    … …  
    769766              zTnorm=zumid_ice*e2u(k%I,k%J)+zvmid_ice*e1v(k%I,k%J) 
    770767 
    771 #if defined key_lim2    
    772               transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)*   &  
    773                                    (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  &  
    774                                   *(hsnif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J) +  &  
    775                                     hicif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J)) 
    776               transports_2d(2,jsec,jseg) = transports_2d(2,jsec,jseg) + (zTnorm)*   &  
    777                                     (1.0 -  frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J)) 
    778 #endif 
    779768#if defined key_lim3 
    780769              DO jl=1,jpl 
    781                  transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)*     & 
    782                                    a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) * & 
    783                                   ( ht_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) +  & 
    784                                     ht_s(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) ) 
     770                 transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)*       & 
     771                                    a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) * & 
     772                                  ( h_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) +  & 
     773                                    h_s(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) ) 
    785774                                    
    786775                 transports_2d(2,jsec,jseg) = transports_2d(2,jsec,jseg) + (zTnorm)*   & 
    787                                    a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) 
     776                                    a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) 
    788777              END DO 
    789778#endif 
    … …  
    874863           !---------------------------|  
    875864           !Sum of the transport on the vertical   
    876            DO jk=1,mbathy(k%I,k%J)  
     865           DO jk=1,mbkt(k%I,k%J)  
    877866  
    878867              ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point  
    … …  
    956945                 ENDIF ! end of test if point is in class  
    957946     
    958               ENDDO ! end of loop on the classes  
    959   
    960            ENDDO ! loop over jk  
    961   
    962 #if defined key_lim2 || defined key_lim3  
     947              END DO ! end of loop on the classes  
     948  
     949           END DO ! loop over jk  
     950  
     951#if defined key_lim3  
    963952  
    964953           !ICE CASE      

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r8215 r8586  
    5151   USE ioipsl         !  
    5252 
    53 #if defined key_lim2 
    54    USE limwri_2  
    55 #elif defined key_lim3 
    56    USE limwri  
     53#if defined key_lim3 
     54   USE icewri  
    5755#endif 
    5856   USE lib_mpp         ! MPP library 
    … …  
    681679#endif 
    682680 
    683          IF( ln_cpl .AND. nn_ice == 2 ) THEN 
    684             CALL histdef( nid_T,"soicetem" , "Ice Surface Temperature"            , "K"      ,   &  ! tn_ice 
    685                &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    686             CALL histdef( nid_T,"soicealb" , "Ice Albedo"                         , "[0,1]"  ,   &  ! alb_ice 
    687                &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    688          ENDIF 
    689  
    690681         CALL histend( nid_T, snc4chunks=snc4set ) 
    691682 
    … …  
    835826#endif 
    836827 
    837       IF( ln_cpl .AND. nn_ice == 2 ) THEN 
    838          CALL histwrite( nid_T, "soicetem", it, tn_ice(:,:,1) , ndim_hT, ndex_hT )   ! surf. ice temperature 
    839          CALL histwrite( nid_T, "soicealb", it, alb_ice(:,:,1), ndim_hT, ndex_hT )   ! ice albedo 
    840       ENDIF 
    841  
    842828      CALL histwrite( nid_U, "vozocrtx", it, un            , ndim_U , ndex_U )    ! i-current 
    843829      CALL histwrite( nid_U, "sozotaux", it, utau          , ndim_hU, ndex_hU )   ! i-wind stress 
    … …  
    980966      ENDIF 
    981967 
    982 #if defined key_lim2 
    983       CALL lim_wri_state_2( kt, id_i, nh_i ) 
    984 #elif defined key_lim3 
    985       CALL lim_wri_state( kt, id_i, nh_i ) 
     968#if defined key_lim3 
     969      IF( nn_ice == 2 ) THEN   ! clem2017: condition in case agrif + lim but no-ice in child grid 
     970         CALL ice_wri_state( kt, id_i, nh_i ) 
     971      ENDIF 
    986972#else 
    987973      CALL histend( id_i, snc4chunks=snc4set ) 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r7646 r8586  
    124124   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2f , r1_e1e2f                !: associated metrics at f-point 
    125125   ! 
    126    REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   ff_f, ff_t                      !: coriolis factor at f- and t-point         [1/s] 
     126   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   ff_f  , ff_t                    !: Coriolis factor at f- & t-points  [1/s] 
    127127   !!---------------------------------------------------------------------- 
    128128   !! vertical coordinate and scale factors 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90

    r8568 r8586  
    180180      END DO 
    181181 
    182       CALL lbc_sum(pvol_flx(:,:,:       ),'T',1.) 
    183       CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 
    184       CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 
    185  
     182!!gm  ERROR !!!! 
     183!!    juste use tmask_i  or in case of ISF smask_i (to be created to compute the sum without halos) 
     184! 
     185!      CALL lbc_sum(pvol_flx(:,:,:       ),'T',1.) 
     186!      CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 
     187!      CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 
     188      STOP ' iscpl_cons:   please modify this module !' 
     189!!gm end 
    186190      ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point  
    187191      ! allocation and initialisation of the list of problematic point 
    … …  
    279283      pts_flx (:,:,:,jp_tem) = pts_flx (:,:,:,jp_tem) * tmask(:,:,:) 
    280284 
    281       ! compute sum over the halo and set it to 0. 
    282       CALL lbc_sum(pvol_flx(:,:,:       ),'T',1._wp) 
    283       CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 
    284       CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 
     285!!gm  ERROR !!!! 
     286!!    juste use tmask_i  or in case of ISF smask_i (to be created to compute the sum without halos) 
     287! 
     288!      ! compute sum over the halo and set it to 0. 
     289!      CALL lbc_sum(pvol_flx(:,:,:       ),'T',1._wp) 
     290!      CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 
     291!      CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 
     292!!gm end 
     293 
    285294      ! 
    286295   END SUBROUTINE iscpl_cons 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90

    r7813 r8586  
    5454 
    5555   REAL(wp), PUBLIC ::   rhosn    =  330._wp         !: volumic mass of snow          [kg/m3] 
     56   REAL(wp), PUBLIC ::   rhofw    = 1000._wp         !: volumic mass of freshwater in melt ponds [kg/m3] 
    5657   REAL(wp), PUBLIC ::   emic     =    0.97_wp       !: emissivity of snow or ice 
    5758   REAL(wp), PUBLIC ::   sice     =    6.0_wp        !: salinity of ice               [psu] 
    … …  
    8889   REAL(wp), PUBLIC ::   r1_rhoic                    !: 1 / rhoic 
    8990   REAL(wp), PUBLIC ::   r1_rhosn                    !: 1 / rhosn 
     91   REAL(wp), PUBLIC ::   r1_cpic                     !: 1 / cpic 
    9092#endif 
    9193   !!---------------------------------------------------------------------- 
    … …  
    156158      r1_rhoic = 1._wp / rhoic 
    157159      r1_rhosn = 1._wp / rhosn 
     160      r1_cpic  = 1._wp / cpic 
    158161#endif 
    159162      IF(lwp) THEN 
    … …  
    176179         WRITE(numout,*) '          density of sea ice                        = ', rhoic   , ' kg/m^3' 
    177180         WRITE(numout,*) '          density of snow                           = ', rhosn   , ' kg/m^3' 
     181         WRITE(numout,*) '          density of freshwater (in melt ponds)     = ', rhofw   , ' kg/m^3' 
    178182         WRITE(numout,*) '          emissivity of snow or ice                 = ', emic   
    179183         WRITE(numout,*) '          salinity of ice                           = ', sice    , ' psu' 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/divhor.F90

    r8568 r8586  
    8181            END DO   
    8282         END DO   
    83          IF( .NOT. AGRIF_Root() ) THEN 
    84             IF( nbondi ==  1 .OR. nbondi == 2 )   hdivn(nlci-1,   :  ,jk) = 0._wp      ! east 
    85             IF( nbondi == -1 .OR. nbondi == 2 )   hdivn(  2   ,   :  ,jk) = 0._wp      ! west 
    86             IF( nbondj ==  1 .OR. nbondj == 2 )   hdivn(  :   ,nlcj-1,jk) = 0._wp      ! north 
    87             IF( nbondj == -1 .OR. nbondj == 2 )   hdivn(  :   ,  2   ,jk) = 0._wp      ! south 
    88          ENDIF 
    8983      END DO 
     84#if defined key_agrif 
     85      IF( .NOT. Agrif_Root() ) THEN 
     86         IF( nbondi == -1 .OR. nbondi == 2 )   hdivn( 2:nbghostcells+1,:        ,:) = 0._wp      ! west 
     87         IF( nbondi ==  1 .OR. nbondi == 2 )   hdivn( nlci-nbghostcells:nlci-1,:,:) = 0._wp      ! east 
     88         IF( nbondj == -1 .OR. nbondj == 2 )   hdivn( :,2:nbghostcells+1        ,:) = 0._wp      ! south 
     89         IF( nbondj ==  1 .OR. nbondj == 2 )   hdivn( :,nlcj-nbghostcells:nlcj-1,:) = 0._wp      ! north 
     90      ENDIF 
     91#endif 
    9092      ! 
    9193      IF( ln_rnf )   CALL sbc_rnf_div( hdivn )              !==  runoffs    ==!   (update hdivn field) 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90

    r8568 r8586  
    1717   USE phycst         ! physical constants 
    1818   USE sbc_oce        ! surface boundary condition: ocean 
     19   USE sbc_ice , ONLY : snwice_mass, snwice_mass_b 
    1920   USE sbcapr         ! surface boundary condition: atmospheric pressure 
    2021   USE dynspg_exp     ! surface pressure gradient     (dyn_spg_exp routine) 
    … …  
    7071      !!             period is used to prevent the divergence of odd and even time step. 
    7172      !!---------------------------------------------------------------------- 
    72       INTEGER, INTENT(in   ) ::   kt   ! ocean time-step index 
     73      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    7374      ! 
    7475      INTEGER  ::   ji, jj, jk                   ! dummy loop indices 
    … …  
    8889      IF(      ln_apr_dyn                                                &   ! atmos. pressure 
    8990         .OR.  ( .NOT.ln_dynspg_ts .AND. (ln_tide_pot .AND. ln_tide) )   &   ! tide potential (no time slitting) 
    90          .OR.  nn_ice_embd == 2  ) THEN                                      ! embedded sea-ice 
     91         .OR.  ln_ice_embd ) THEN                                            ! embedded sea-ice 
    9192         ! 
    9293         DO jj = 2, jpjm1 
    … …  
    102103               DO ji = fs_2, fs_jpim1   ! vector opt. 
    103104                  spgu(ji,jj) = spgu(ji,jj) + zg_2 * (  ssh_ib (ji+1,jj) - ssh_ib (ji,jj)    & 
    104                      &                      + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
     105                     &                                + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
    105106                  spgv(ji,jj) = spgv(ji,jj) + zg_2 * (  ssh_ib (ji,jj+1) - ssh_ib (ji,jj)    & 
    106                      &                      + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
     107                     &                                + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
    107108               END DO 
    108109            END DO 
    … …  
    122123         ENDIF 
    123124         ! 
    124          IF( nn_ice_embd == 2 ) THEN          !== embedded sea ice: Pressure gradient due to snow-ice mass ==! 
     125         IF( ln_ice_embd ) THEN              !== embedded sea ice: Pressure gradient due to snow-ice mass ==! 
    125126            ALLOCATE( zpice(jpi,jpj) ) 
    126127            zintp = REAL( MOD( kt-1, nn_fsbc ) ) / REAL( nn_fsbc ) 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r8568 r8586  
    206206            DO ji = fs_2, fs_jpim1   ! vector opt. 
    207207               zCdU_u(ji,jj) = 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 
    208                zCdU_v(ji,jj) = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 
     208               zCdU_v(ji,jj) = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 
    209209            END DO 
    210210         END DO 
    … …  
    504504         END DO 
    505505      ELSE 
    506          DO jj = 2, jpjm1                           
     506         DO jj = 2, jpjm1 
    507507            DO ji = fs_2, fs_jpim1   ! vector opt. 
    508508               zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu_n(ji,jj) * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zwx(ji,jj) 
    … …  
    510510            END DO 
    511511         END DO 
    512       END IF 
     512      ENDIF 
    513513      ! 
    514514      IF( ln_isfcav ) THEN       ! Add TOP stress contribution from baroclinic velocities:       
    … …  
    715715         IF( .NOT.Agrif_Root() .AND. ln_bt_fw ) THEN 
    716716            IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    717                DO jj=1,jpj 
    718                   zwx(2,jj) = ubdy_w(jj) * e2u(2,jj) 
     717               DO jj = 1, jpj 
     718                  zwx(2:nbghostcells+1,jj) = ubdy_w(jj) * e2u(2:nbghostcells+1,jj) 
    719719               END DO 
    720720            ENDIF 
    721721            IF((nbondi ==  1).OR.(nbondi == 2)) THEN 
    722722               DO jj=1,jpj 
    723                   zwx(nlci-2,jj) = ubdy_e(jj) * e2u(nlci-2,jj) 
     723                  zwx(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) 
    724724               END DO 
    725725            ENDIF 
    726726            IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    727727               DO ji=1,jpi 
    728                   zwy(ji,2) = vbdy_s(ji) * e1v(ji,2) 
     728                  zwy(ji,2:nbghostcells+1) = vbdy_s(ji) * e1v(ji,2:nbghostcells+1) 
    729729               END DO 
    730730            ENDIF 
    731731            IF((nbondj ==  1).OR.(nbondj == 2)) THEN 
    732732               DO ji=1,jpi 
    733                   zwy(ji,nlcj-2) = vbdy_n(ji) * e1v(ji,nlcj-2) 
     733                  zwy(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) 
    734734               END DO 
    735735            ENDIF 
    … …  
    915915         ENDIF 
    916916         ! 
    917          DO jj = 2, jpjm1 
    918             DO ji = fs_2, fs_jpim1   ! vector opt. 
    919                ! Add top/bottom stresses: 
    920 !!gm old/new 
     917         DO jj = 2, jpjm1               ! Add top/bottom stresses: 
     918            DO ji = fs_2, fs_jpim1   ! vector opt. 
    921919               zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj) 
    922920               zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj) 
    923 !!gm 
    924921            END DO 
    925922         END DO 
    926923         ! 
    927924         ! Surface pressure trend: 
    928  
    929925         IF( ln_wd ) THEN 
    930926           DO jj = 2, jpjm1 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90

    r8568 r8586  
    184184      !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 
    185185      !!---------------------------------------------------------------------- 
    186       INTEGER                          , INTENT(in   )::   kt          ! ocean time-step index 
    187       INTEGER                          , INTENT(in   )::   kvor        ! total, planetary, relative, or metric 
     186      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index 
     187      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
    188188      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities 
    189189      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend 
    … …  
    301301      !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 
    302302      !!---------------------------------------------------------------------- 
    303       INTEGER                          , INTENT(in   )::   kt          ! ocean time-step index 
    304       INTEGER                          , INTENT(in   )::   kvor        ! total, planetary, relative, or metric 
     303      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index 
     304      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
    305305      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities 
    306306      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend 
    … …  
    414414      !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 
    415415      !!---------------------------------------------------------------------- 
    416       INTEGER                          , INTENT(in   )::   kt          ! ocean time-step index 
    417       INTEGER                          , INTENT(in   )::   kvor        ! total, planetary, relative, or metric 
     416      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index 
     417      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
    418418      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities 
    419419      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf.F90

    r8568 r8586  
    6666      !! ** Action :   (ua,va)   after velocity  
    6767      !!--------------------------------------------------------------------- 
    68       INTEGER , INTENT(in) ::  kt     ! ocean time-step index 
     68      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    6969      ! 
    7070      INTEGER  ::   ji, jj, jk         ! dummy loop indices 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/wet_dry.F90

    r8568 r8586  
    244244      !IF( ln_rnf      )   CALL sbc_rnf_div( hdivn )          ! runoffs (update hdivn field) 
    245245      !IF( nn_cla == 1 )   CALL cla_div    ( kt )             ! Cross Land Advection (update hdivn field) 
    246       ! 
    247246      ! 
    248247      ! 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ICB/icb_oce.F90

    r6140 r8586  
    9090   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ua_e, va_e 
    9191   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ssh_e 
    92 #if defined key_lim2 || defined key_lim3 || defined key_cice 
     92#if defined key_lim3 || defined key_cice 
    9393   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ui_e, vi_e 
    9494#endif 
    … …  
    170170      ALLOCATE( uo_e(0:jpi+1,0:jpj+1) , ua_e(0:jpi+1,0:jpj+1) ,   & 
    171171         &      vo_e(0:jpi+1,0:jpj+1) , va_e(0:jpi+1,0:jpj+1) ,   & 
    172 #if defined key_lim2 || defined key_lim3 || defined key_cice 
     172#if defined key_lim3 || defined key_cice 
    173173         &      ui_e(0:jpi+1,0:jpj+1) ,                            & 
    174174         &      vi_e(0:jpi+1,0:jpj+1) ,                            & 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ICB/icbtrj.F90

    r5215 r8586  
    1616   USE dom_oce        ! NEMO ocean domain 
    1717   USE phycst         ! NEMO physical constants 
     18   USE icb_oce        ! define iceberg arrays 
     19   USE icbutl         ! iceberg utility routines 
     20   ! 
    1821   USE lib_mpp        ! NEMO MPI library, lk_mpp in particular 
    1922   USE in_out_manager ! NEMO IO, numout in particular 
     23   USE ioipsl  , ONLY : ju2ymds    ! for calendar 
    2024   USE netcdf 
    2125   ! 
    22    USE icb_oce        ! define iceberg arrays 
    23    USE icbutl         ! iceberg utility routines 
    2426 
    2527   IMPLICIT NONE 
    … …  
    5759      !! ** Purpose :   initialise iceberg trajectory output files 
    5860      !!---------------------------------------------------------------------- 
    59       INTEGER, INTENT( in )                 :: ktend 
    60       ! 
    61       INTEGER                               :: iret 
    62       CHARACTER(len=80)                     :: cl_filename 
    63       TYPE(iceberg), POINTER                :: this 
    64       TYPE(point)  , POINTER                :: pt 
    65       !!---------------------------------------------------------------------- 
    66  
    67       IF( lk_mpp ) THEN   ;   WRITE(cl_filename,'("trajectory_icebergs_",I6.6,"_",I4.4,".nc")') ktend, narea-1 
    68       ELSE                ;   WRITE(cl_filename,'("trajectory_icebergs_",I6.6         ,".nc")') ktend 
     61      INTEGER, INTENT(in) ::   ktend   ! time step index 
     62      ! 
     63      INTEGER                :: iret, iyear, imonth, iday 
     64      REAL(wp)               :: zfjulday, zsec 
     65      CHARACTER(len=80)      :: cl_filename 
     66      CHARACTER(LEN=20)      :: cldate_ini, cldate_end 
     67      TYPE(iceberg), POINTER :: this 
     68      TYPE(point)  , POINTER :: pt 
     69      !!---------------------------------------------------------------------- 
     70 
     71      ! compute initial time step date 
     72      CALL ju2ymds( fjulday, iyear, imonth, iday, zsec ) 
     73      WRITE(cldate_ini, '(i4.4,2i2.2)') iyear, imonth, iday 
     74 
     75      ! compute end time step date 
     76      zfjulday = fjulday + rdt / rday * REAL( nitend - nit000 + 1 , wp) 
     77      IF( ABS(zfjulday - REAL(NINT(zfjulday),wp)) < 0.1 / rday )   zfjulday = REAL(NINT(zfjulday),wp)   ! avoid truncation error 
     78      CALL ju2ymds( zfjulday, iyear, imonth, iday, zsec ) 
     79      WRITE(cldate_end, '(i4.4,2i2.2)') iyear, imonth, iday 
     80 
     81      ! define trajectory output name 
     82      IF( lk_mpp ) THEN   ;   WRITE(cl_filename,'("trajectory_icebergs_",A,"-",A,"_",I4.4,".nc")') TRIM(ADJUSTL(cldate_ini)), TRIM(ADJUSTL(cldate_end)), narea-1 
     83      ELSE                ;   WRITE(cl_filename,'("trajectory_icebergs_",A,"-",A         ,".nc")') TRIM(ADJUSTL(cldate_ini)), TRIM(ADJUSTL(cldate_end)) 
    6984      ENDIF 
    7085      IF ( lwp .AND. nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, icb_trj_init: creating ',TRIM(cl_filename) 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ICB/icbutl.F90

    r7646 r8586  
    2121   USE icb_oce                             ! define iceberg arrays 
    2222   USE sbc_oce                             ! ocean surface boundary conditions 
    23 #if defined key_lim2 
    24    USE ice_2,         ONLY: u_ice, v_ice   ! LIM-2 ice velocities  (CAUTION in C-grid do not use key_vp option) 
    25    USE ice_2,         ONLY: hicif          ! LIM-2 ice thickness 
    26 #elif defined key_lim3 
    27    USE ice,           ONLY: u_ice, v_ice   ! LIM-3 variables  (always in C-grid) 
    28                                            ! gm  LIM3 case the mean ice thickness (i.e. averaged over categories) 
    29                                            ! gm            has to be computed somewhere in the ice and accessed here 
     23#if defined key_lim3 
     24   USE ice,    ONLY: u_ice, v_ice, hm_i    ! LIM-3 variables 
    3025#endif 
    3126 
    … …  
    8580      CALL lbc_lnk_icb( fr_e, 'T', +1._wp, 1, 1 ) 
    8681      CALL lbc_lnk_icb( tt_e, 'T', +1._wp, 1, 1 ) 
    87 #if defined key_lim2 
    88       hicth(:,:) = 0._wp ;  hicth(1:jpi,1:jpj) = hicif(:,:)   
    89       CALL lbc_lnk_icb(hicth, 'T', +1._wp, 1, 1 )   
    90 #endif 
    91  
    92 #if defined key_lim2 || defined key_lim3 
     82#if defined key_lim3 
     83      hicth(:,:) = 0._wp ;  hicth(1:jpi,1:jpj) = hm_i (:,:)   
    9384      ui_e(:,:) = 0._wp ;   ui_e(1:jpi, 1:jpj) = u_ice(:,:) 
    9485      vi_e(:,:) = 0._wp ;   vi_e(1:jpi, 1:jpj) = v_ice(:,:) 
    95  
     86      CALL lbc_lnk_icb(hicth, 'T', +1._wp, 1, 1 ) 
    9687      CALL lbc_lnk_icb( ui_e, 'U', -1._wp, 1, 1 ) 
    9788      CALL lbc_lnk_icb( vi_e, 'V', -1._wp, 1, 1 ) 
    … …  
    157148      pva  = pva * zmod 
    158149 
    159 #if defined key_lim2 || defined key_lim3 
     150#if defined key_lim3 
    160151      pui = icb_utl_bilin_h( ui_e, pi, pj, 'U' )              ! sea-ice velocities 
    161152      pvi = icb_utl_bilin_h( vi_e, pi, pj, 'V' ) 
    162 # if defined key_lim3 
    163       phi = 0._wp                                             ! LIM-3 case (to do) 
    164 # else 
    165153      phi = icb_utl_bilin_h(hicth, pi, pj, 'T' )              ! ice thickness 
    166 # endif 
    167154#else 
    168155      pui = 0._wp 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90

    r8568 r8586  
    8888   INTEGER ::   nitrst                !: time step at which restart file should be written 
    8989   LOGICAL ::   lrst_oce              !: logical to control the oce restart write  
     90   LOGICAL ::   lrst_ice              !: logical to control the ice restart write  
    9091   INTEGER ::   numror = 0            !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) 
     92   INTEGER ::   numrir                !: logical unit for ice   restart (read) 
    9193   INTEGER ::   numrow                !: logical unit for ocean restart (write) 
     94   INTEGER ::   numriw                !: logical unit for ice   restart (write) 
    9295   INTEGER ::   nrst_lst              !: number of restart to output next 
    9396 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r7768 r8586  
    3434#if defined key_lim3 
    3535   USE ice    , ONLY :   jpl 
    36 #elif defined key_lim2 
    37    USE par_ice_2 
    3836#endif 
    3937   USE domngb          ! ocean space and time domain 
    … …  
    193191      CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) 
    194192# endif 
    195 #if defined key_lim3 || defined key_lim2 
     193#if defined key_lim3 
    196194      CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 
     195      ! SIMIP diagnostics (4 main arctic straits) 
     196      CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) 
    197197#endif 
    198198      CALL iom_set_axis_attr( "icbcla", class_num ) 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r8215 r8586  
    22   !!====================================================================== 
    33   !!                       ***  MODULE  lbclnk  *** 
    4    !! NEMO : lateral boundary conditions --- MPP exchanges 
     4   !! NEMO        : lateral boundary conditions 
    55   !!===================================================================== 
    66   !! History :  OPA  ! 1997-06  (G. Madec)  Original code 
    77   !!   NEMO     1.0  ! 2002-09  (G. Madec)  F90: Free form and module 
    88   !!            3.2  ! 2009-03  (R. Benshila)  External north fold treatment   
    9    !!            3.5  ! 2012     (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 
     9   !!            3.5  ! 2012     (S.Mocavero, I. Epicoco)  optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 
    1010   !!            3.4  ! 2012-12  (R. Bourdalle-Badie, G. Reffray)  add a C1D case   
    1111   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi   
    1212   !!            4.0  ! 2017-03  (G. Madec) automatique allocation of array size (use with any 3rd dim size) 
    1313   !!             -   ! 2017-04  (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather) 
     14   !!             -   ! 2017-05  (G. Madec) create generic.h90 files to generate all lbc and north fold routines 
    1415   !!---------------------------------------------------------------------- 
    1516#if defined key_mpp_mpi 
    … …  
    2021   !!---------------------------------------------------------------------- 
    2122   !!   lbc_lnk       : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 
    22    !!   lbc_sum       : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp 
    2323   !!   lbc_lnk_e     : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 
    2424   !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
    2525   !!---------------------------------------------------------------------- 
     26   USE par_oce        ! ocean dynamics and tracers    
    2627   USE lib_mpp        ! distributed memory computing library 
    27  
     28   USE lbcnfd         ! north fold 
     29 
     30   INTERFACE lbc_lnk 
     31      MODULE PROCEDURE   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d 
     32   END INTERFACE 
     33   INTERFACE lbc_lnk_ptr 
     34      MODULE PROCEDURE   mpp_lnk_2d_ptr  , mpp_lnk_3d_ptr  , mpp_lnk_4d_ptr 
     35   END INTERFACE 
    2836   INTERFACE lbc_lnk_multi 
    29       MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
    30    END INTERFACE 
    31    ! 
    32    INTERFACE lbc_lnk 
    33       MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 
    34    END INTERFACE 
    35    ! 
    36    INTERFACE lbc_sum 
    37       MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 
     37      MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 
    3838   END INTERFACE 
    3939   ! 
    … …  
    5252   PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions 
    5353   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    54    PUBLIC   lbc_sum       ! sum across processors 
    5554   PUBLIC   lbc_lnk_e     ! extended ocean/ice lateral boundary conditions 
    5655   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    … …  
    6261   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    6362   !!---------------------------------------------------------------------- 
     63CONTAINS 
     64 
    6465#else 
    6566   !!---------------------------------------------------------------------- 
    … …  
    6970   !!         on first and last row and column of the global domain 
    7071   !!---------------------------------------------------------------------- 
    71    !!   lbc_sum       : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d  
    7272   !!   lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 
    7373   !!   lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh 
    … …  
    8686 
    8787   INTERFACE lbc_lnk 
    88       MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d 
    89    END INTERFACE 
    90    ! 
    91    INTERFACE lbc_sum 
    92       MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 
     88      MODULE PROCEDURE   lbc_lnk_2d      , lbc_lnk_3d      , lbc_lnk_4d 
     89   END INTERFACE 
     90   INTERFACE lbc_lnk_ptr 
     91      MODULE PROCEDURE   lbc_lnk_2d_ptr  , lbc_lnk_3d_ptr  , lbc_lnk_4d_ptr 
     92   END INTERFACE 
     93   INTERFACE lbc_lnk_multi 
     94      MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 
    9395   END INTERFACE 
    9496   ! 
    … …  
    9799   END INTERFACE 
    98100   ! 
    99    INTERFACE lbc_lnk_multi 
    100       MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
    101    END INTERFACE 
    102    ! 
    103101   INTERFACE lbc_bdy_lnk 
    104102      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
    … …  
    109107   END INTERFACE 
    110108    
    111    TYPE arrayptr 
    112       REAL , DIMENSION (:,:),  POINTER :: pt2d 
    113    END TYPE arrayptr 
    114    ! 
    115    PUBLIC   arrayptr 
    116  
    117109   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    118    PUBLIC   lbc_sum       ! ocean/ice  lateral boundary conditions (sum of the overlap region) 
    119110   PUBLIC   lbc_lnk_e     ! extended ocean/ice lateral boundary conditions 
    120111   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    … …  
    130121 
    131122# if defined key_c1d 
    132    !!---------------------------------------------------------------------- 
     123   !!====================================================================== 
    133124   !!   'key_c1d'                                          1D configuration 
    134    !!---------------------------------------------------------------------- 
     125   !!====================================================================== 
    135126   !!     central point value replicated over the 8 surrounding points 
    136127   !!---------------------------------------------------------------------- 
    … …  
    185176    
    186177#else 
    187    !!---------------------------------------------------------------------- 
     178   !!====================================================================== 
    188179   !!   Default option                           3D shared memory computing 
    189    !!---------------------------------------------------------------------- 
     180   !!====================================================================== 
    190181   !!          routines setting land point, or east-west cyclic, 
    191182   !!             or north-south cyclic, or north fold values 
    … …  
    193184   !!---------------------------------------------------------------------- 
    194185 
    195    SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
    196       !!--------------------------------------------------------------------- 
    197       !!                  ***  ROUTINE lbc_lnk_3d  *** 
    198       !! 
    199       !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case) 
    200       !! 
    201       !! ** Method  :   psign = -1 :    change the sign across the north fold 
    202       !!                      =  1 : no change of the sign across the north fold 
    203       !!                      =  0 : no change of the sign across the north fold and 
    204       !!                             strict positivity preserved: use inner row/column 
    205       !!                             for closed boundaries. 
    206       !!---------------------------------------------------------------------- 
    207       REAL(wp), DIMENSION(:,:,:), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    208       CHARACTER(len=1)          , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    209       REAL(wp)                  , INTENT(in   )           ::   psgn      ! sign used across north fold  
    210       CHARACTER(len=3)          , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    211       REAL(wp)                  , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    212       ! 
    213       REAL(wp) ::   zland 
    214       !!---------------------------------------------------------------------- 
    215       ! 
    216       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    217       ELSE                         ;   zland = 0._wp 
    218       ENDIF 
    219       ! 
    220       IF( PRESENT( cd_mpp ) ) THEN 
    221          ! only fill the overlap area and extra allows  
    222          ! this is in mpp case. In this module, just do nothing 
    223       ELSE 
    224          !                                     !  East-West boundaries 
    225          !                                     ! ====================== 
    226          SELECT CASE ( nperio ) 
    227          ! 
    228          CASE ( 1 , 4 , 6 )                       !**  cyclic east-west 
    229             pt3d( 1 ,:,:) = pt3d(jpim1,:,:)            ! all points 
    230             pt3d(jpi,:,:) = pt3d(  2  ,:,:) 
    231             ! 
    232          CASE DEFAULT                             !**  East closed  --  West closed 
    233             SELECT CASE ( cd_type ) 
    234             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    235                pt3d( 1 ,:,:) = zland 
    236                pt3d(jpi,:,:) = zland 
    237             CASE ( 'F' )                               ! F-point 
    238                pt3d(jpi,:,:) = zland 
    239             END SELECT 
    240             ! 
    241          END SELECT 
    242          !                                     ! North-South boundaries 
    243          !                                     ! ====================== 
    244          SELECT CASE ( nperio ) 
    245          ! 
    246          CASE ( 2 )                               !**  South symmetric  --  North closed 
    247             SELECT CASE ( cd_type ) 
    248             CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points 
    249                pt3d(:, 1 ,:) = pt3d(:,3,:) 
    250                pt3d(:,jpj,:) = zland 
    251             CASE ( 'V' , 'F' )                         ! V-, F-points 
    252                pt3d(:, 1 ,:) = psgn * pt3d(:,2,:) 
    253                pt3d(:,jpj,:) = zland 
    254             END SELECT 
    255             ! 
    256          CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed 
    257             SELECT CASE ( cd_type )                    ! South : closed 
    258             CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point 
    259                pt3d(:, 1 ,:) = zland 
    260             END SELECT 
    261             !                                          ! North fold 
    262             CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn ) 
    263             ! 
    264          CASE DEFAULT                             !**  North closed  --  South closed 
    265             SELECT CASE ( cd_type ) 
    266             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    267                pt3d(:, 1 ,:) = zland 
    268                pt3d(:,jpj,:) = zland 
    269             CASE ( 'F' )                               ! F-point 
    270                pt3d(:,jpj,:) = zland 
    271             END SELECT 
    272             ! 
    273          END SELECT 
    274          ! 
    275       ENDIF 
    276       ! 
    277    END SUBROUTINE lbc_lnk_3d 
    278  
    279  
    280    SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    281       !!--------------------------------------------------------------------- 
    282       !!                 ***  ROUTINE lbc_lnk_2d  *** 
    283       !! 
    284       !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
    285       !! 
    286       !! ** Method  :   psign = -1 :    change the sign across the north fold 
    287       !!                      =  1 : no change of the sign across the north fold 
    288       !!                      =  0 : no change of the sign across the north fold and 
    289       !!                             strict positivity preserved: use inner row/column 
    290       !!                             for closed boundaries. 
    291       !!---------------------------------------------------------------------- 
    292       CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    293       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    294       REAL(wp)                    , INTENT(in   )           ::   psgn      ! sign used across north fold 
    295       CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    296       REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    297       !! 
    298       REAL(wp) ::   zland 
    299       !!---------------------------------------------------------------------- 
    300  
    301       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    302       ELSE                         ;   zland = 0._wp 
    303       ENDIF 
    304  
    305       IF (PRESENT(cd_mpp)) THEN 
    306          ! only fill the overlap area and extra allows  
    307          ! this is in mpp case. In this module, just do nothing 
    308       ELSE       
    309          !                                     ! East-West boundaries 
    310          !                                     ! ==================== 
    311          SELECT CASE ( nperio ) 
    312          ! 
    313          CASE ( 1 , 4 , 6 )                       !** cyclic east-west 
    314             pt2d( 1 ,:) = pt2d(jpim1,:)               ! all points 
    315             pt2d(jpi,:) = pt2d(  2  ,:) 
    316             ! 
    317          CASE DEFAULT                             !** East closed  --  West closed 
    318             SELECT CASE ( cd_type ) 
    319             CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points 
    320                pt2d( 1 ,:) = zland 
    321                pt2d(jpi,:) = zland 
    322             CASE ( 'F' )                              ! F-point 
    323                pt2d(jpi,:) = zland 
    324             END SELECT 
    325             ! 
    326          END SELECT 
    327          !                                     ! North-South boundaries 
    328          !                                     ! ====================== 
    329          SELECT CASE ( nperio ) 
    330          ! 
    331          CASE ( 2 )                               !**  South symmetric  --  North closed 
    332             SELECT CASE ( cd_type ) 
    333             CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points 
    334                pt2d(:, 1 ) = pt2d(:,3) 
    335                pt2d(:,jpj) = zland 
    336             CASE ( 'V' , 'F' )                         ! V-, F-points 
    337                pt2d(:, 1 ) = psgn * pt2d(:,2) 
    338                pt2d(:,jpj) = zland 
    339             END SELECT 
    340             ! 
    341          CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed 
    342             SELECT CASE ( cd_type )                    ! South : closed 
    343             CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point 
    344                pt2d(:, 1 ) = zland 
    345             END SELECT 
    346             !                                          ! North fold 
    347             CALL lbc_nfd( pt2d(:,:), cd_type, psgn ) 
    348             ! 
    349          CASE DEFAULT                             !**  North closed  --  South closed 
    350             SELECT CASE ( cd_type ) 
    351             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    352                pt2d(:, 1 ) = zland 
    353                pt2d(:,jpj) = zland 
    354             CASE ( 'F' )                               ! F-point 
    355                pt2d(:,jpj) = zland 
    356             END SELECT 
    357             ! 
    358          END SELECT 
    359          ! 
    360       ENDIF 
    361       !     
    362    END SUBROUTINE lbc_lnk_2d 
     186   !!---------------------------------------------------------------------- 
     187   !!                   ***  routine lbc_lnk_(2,3,4)d  *** 
     188   !! 
     189   !!   * Argument : dummy argument use in lbc_lnk_... routines 
     190   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     191   !!                cd_nat :   nature of array grid-points 
     192   !!                psgn   :   sign used across the north fold boundary 
     193   !!                kfld   :   optional, number of pt3d arrays 
     194   !!                cd_mpp :   optional, fill the overlap area only 
     195   !!                pval   :   optional, background value (used at closed boundaries) 
     196   !!---------------------------------------------------------------------- 
     197   ! 
     198   !                       !==  2D array and array of 2D pointer  ==! 
     199   ! 
     200#  define DIM_2d 
     201#     define ROUTINE_LNK           lbc_lnk_2d 
     202#     include "lbc_lnk_generic.h90" 
     203#     undef ROUTINE_LNK 
     204#     define MULTI 
     205#     define ROUTINE_LNK           lbc_lnk_2d_ptr 
     206#     include "lbc_lnk_generic.h90" 
     207#     undef ROUTINE_LNK 
     208#     undef MULTI 
     209#  undef DIM_2d 
     210   ! 
     211   !                       !==  3D array and array of 3D pointer  ==! 
     212   ! 
     213#  define DIM_3d 
     214#     define ROUTINE_LNK           lbc_lnk_3d 
     215#     include "lbc_lnk_generic.h90" 
     216#     undef ROUTINE_LNK 
     217#     define MULTI 
     218#     define ROUTINE_LNK           lbc_lnk_3d_ptr 
     219#     include "lbc_lnk_generic.h90" 
     220#     undef ROUTINE_LNK 
     221#     undef MULTI 
     222#  undef DIM_3d 
     223   ! 
     224   !                       !==  4D array and array of 4D pointer  ==! 
     225   ! 
     226#  define DIM_4d 
     227#     define ROUTINE_LNK           lbc_lnk_4d 
     228#     include "lbc_lnk_generic.h90" 
     229#     undef ROUTINE_LNK 
     230#     define MULTI 
     231#     define ROUTINE_LNK           lbc_lnk_4d_ptr 
     232#     include "lbc_lnk_generic.h90" 
     233#     undef ROUTINE_LNK 
     234#     undef MULTI 
     235#  undef DIM_4d 
    363236    
    364237#endif 
    365238 
    366    !!---------------------------------------------------------------------- 
    367    !!   identical routines in both C1D and shared memory computing cases 
    368    !!---------------------------------------------------------------------- 
    369  
    370    SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 
    371       !!--------------------------------------------------------------------- 
    372       !!                  ***  ROUTINE lbc_lnk_3d_gather  *** 
    373       !! 
    374       !! ** Purpose :   set lateral boundary conditions on two 3D arrays (C1D case) 
    375       !! 
    376       !! ** Method  :   call lbc_lnk_3d on pt3d1 and pt3d2 
    377       !!---------------------------------------------------------------------- 
    378       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied 
    379       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d1 & pt3d2 grid-points 
    380       REAL(wp)                  , INTENT(in   ) ::   psgn                 ! sign used across north fold  
    381       !!---------------------------------------------------------------------- 
    382       ! 
    383       CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 
    384       CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 
    385       ! 
    386    END SUBROUTINE lbc_lnk_3d_gather 
    387  
    388    
    389    SUBROUTINE lbc_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld ) 
    390       !!--------------------------------------------------------------------- 
    391       TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields 
    392       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! nature of ptab_array grid-points 
    393       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! sign used across the north fold boundary 
    394       INTEGER                       , INTENT(in   ) ::   kfld         ! number of 2D fields 
    395       ! 
    396       INTEGER  ::   jf    !dummy loop index 
    397       !!--------------------------------------------------------------------- 
    398       ! 
    399       DO jf = 1, kfld 
    400         CALL lbc_lnk_2d( pt2d_array(jf)%pt2d, type_array(jf), psgn_array(jf) ) 
    401       END DO      
    402       ! 
    403    END SUBROUTINE lbc_lnk_2d_multiple 
    404  
    405  
    406    SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC,   & 
    407       &                     pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF,   & 
    408       &                     pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI,   & 
    409       &                     cd_mpp, pval ) 
    410       !!--------------------------------------------------------------------- 
    411       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA    ! 2D arrays on which the lbc is applied 
    412       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    413       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
    414       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA ! nature of pt2D. array grid-points 
    415       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    416       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    417       REAL(wp)                                      , INTENT(in   ) ::   psgnA    ! sign used across the north fold 
    418       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    419       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
    420       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    421       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    422       !! 
    423       !!--------------------------------------------------------------------- 
    424       ! 
    425                               CALL lbc_lnk( pt2dA, cd_typeA, psgnA )    ! The first array 
    426       !           
    427       IF( PRESENT (psgnB) )   CALL lbc_lnk( pt2dB, cd_typeB, psgnB )    ! Look if more arrays to process 
    428       IF( PRESENT (psgnC) )   CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
    429       IF( PRESENT (psgnD) )   CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
    430       IF( PRESENT (psgnE) )   CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
    431       IF( PRESENT (psgnF) )   CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
    432       IF( PRESENT (psgnG) )   CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
    433       IF( PRESENT (psgnH) )   CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
    434       IF( PRESENT (psgnI) )   CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
    435       ! 
    436    END SUBROUTINE lbc_lnk_2d_9 
    437  
    438  
     239   !!====================================================================== 
     240   !!   identical routines in both C1D and shared memory computing 
     241   !!====================================================================== 
     242 
     243   !!---------------------------------------------------------------------- 
     244   !!                   ***  routine lbc_bdy_lnk_(2,3)d  *** 
     245   !! 
     246   !!   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
     247   !!   to maintain the same interface with regards to the mpp case 
     248   !!---------------------------------------------------------------------- 
     249    
    439250   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 
    440       !!--------------------------------------------------------------------- 
    441       !!                  ***  ROUTINE lbc_bdy_lnk  *** 
    442       !! 
    443       !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    444       !!              to maintain the same interface with regards to the mpp case 
    445251      !!---------------------------------------------------------------------- 
    446252      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied 
    … …  
    449255      INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    450256      !!---------------------------------------------------------------------- 
    451       ! 
    452257      CALL lbc_lnk_3d( pt3d, cd_type, psgn) 
    453       ! 
    454258   END SUBROUTINE lbc_bdy_lnk_3d 
    455259 
    456260 
    457261   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 
    458       !!--------------------------------------------------------------------- 
    459       !!                  ***  ROUTINE lbc_bdy_lnk  *** 
    460       !! 
    461       !! ** Purpose :   wrapper rountine to 'lbc_lnk_2d'. This wrapper is used 
    462       !!              to maintain the same interface with regards to the mpp case 
    463262      !!---------------------------------------------------------------------- 
    464263      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied 
    … …  
    467266      INTEGER                 , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    468267      !!---------------------------------------------------------------------- 
    469       ! 
    470268      CALL lbc_lnk_2d( pt2d, cd_type, psgn) 
    471       ! 
    472269   END SUBROUTINE lbc_bdy_lnk_2d 
    473270 
    474271 
     272!!gm  This routine should be remove with an optional halos size added in orgument of generic routines 
     273 
    475274   SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, ki, kj ) 
    476       !!--------------------------------------------------------------------- 
    477       !!                 ***  ROUTINE lbc_lnk_2d  *** 
    478       !! 
    479       !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
    480       !!                special dummy routine to allow for use of halo indexing in mpp case 
    481275      !!---------------------------------------------------------------------- 
    482276      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
    … …  
    485279      INTEGER                 , INTENT(in   ) ::   ki, kj    ! sizes of extra halo (not needed in non-mpp) 
    486280      !!---------------------------------------------------------------------- 
    487       ! 
    488281      CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 
    489       !     
    490282   END SUBROUTINE lbc_lnk_2d_e 
    491  
    492  
    493    SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    494       !!--------------------------------------------------------------------- 
    495       !!                 ***  ROUTINE lbc_lnk_sum_2d  *** 
    496       !! 
    497       !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
    498       !! 
    499       !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean  
    500       !!                coupling if conservation option activated. As no ice shelf are present along 
    501       !!                this line, nothing is done along the north fold. 
    502       !!---------------------------------------------------------------------- 
    503       CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    504       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
    505       REAL(wp)                    , INTENT(in   )           ::   psgn      ! sign used across north fold  
    506       CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    507       REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    508       !! 
    509       REAL(wp) ::   zland 
    510       !!---------------------------------------------------------------------- 
    511       ! 
    512       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    513       ELSE                         ;   zland = 0._wp 
    514       ENDIF 
    515       ! 
    516       IF (PRESENT(cd_mpp)) THEN 
    517          ! only fill the overlap area and extra allows  
    518          ! this is in mpp case. In this module, just do nothing 
    519       ELSE 
    520          !                                     ! East-West boundaries 
    521          !                                     ! ==================== 
    522          SELECT CASE ( nperio ) 
    523          ! 
    524          CASE ( 1 , 4 , 6 )                       !** cyclic east-west 
    525             pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:) 
    526             pt2d(  2  ,:) = pt2d(  2  ,:) + pt2d(jpi,:) 
    527             pt2d( 1 ,:) = 0.0_wp               ! all points 
    528             pt2d(jpi,:) = 0.0_wp 
    529             ! 
    530          CASE DEFAULT                             !** East closed  --  West closed 
    531             SELECT CASE ( cd_type ) 
    532             CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points 
    533                pt2d( 1 ,:) = zland 
    534                pt2d(jpi,:) = zland 
    535             CASE ( 'F' )                              ! F-point 
    536                pt2d(jpi,:) = zland 
    537             END SELECT 
    538             ! 
    539          END SELECT 
    540          !                                     ! North-South boundaries 
    541          !                                     ! ====================== 
    542          ! Nothing to do for the north fold, there is no ice shelf along this line. 
    543          ! 
    544       END IF 
    545       ! 
    546    END SUBROUTINE 
    547  
    548  
    549    SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
    550       !!--------------------------------------------------------------------- 
    551       !!                 ***  ROUTINE lbc_lnk_sum_3d  *** 
    552       !! 
    553       !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case) 
    554       !! 
    555       !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean  
    556       !!                coupling if conservation option activated. As no ice shelf are present along 
    557       !!                this line, nothing is done along the north fold. 
    558       !!---------------------------------------------------------------------- 
    559       REAL(wp), DIMENSION(:,:,:), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    560       CHARACTER(len=1)          , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    561       REAL(wp)                  , INTENT(in   )           ::   psgn      ! sign used across north fold  
    562       CHARACTER(len=3)          , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
    563       REAL(wp)                  , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
    564       ! 
    565       REAL(wp) ::   zland 
    566       !!---------------------------------------------------------------------- 
    567       ! 
    568       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
    569       ELSE                         ;   zland = 0._wp 
    570       ENDIF 
    571       ! 
    572       IF( PRESENT( cd_mpp ) ) THEN 
    573          ! only fill the overlap area and extra allows  
    574          ! this is in mpp case. In this module, just do nothing 
    575       ELSE 
    576          !                                     !  East-West boundaries 
    577          !                                     ! ====================== 
    578          SELECT CASE ( nperio ) 
    579          ! 
    580          CASE ( 1 , 4 , 6 )                       !**  cyclic east-west 
    581             pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 
    582             pt3d(  2  ,:,:) = pt3d(  2  ,:,:) + pt3d(jpi,:,:)  
    583             pt3d( 1 ,:,:) = 0._wp 
    584             pt3d(jpi,:,:) = 0._wp 
    585             ! 
    586          CASE DEFAULT                             !**  East closed  --  West closed 
    587             SELECT CASE ( cd_type ) 
    588             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    589                pt3d( 1 ,:,:) = zland 
    590                pt3d(jpi,:,:) = zland 
    591             CASE ( 'F' )                               ! F-point 
    592                pt3d(jpi,:,:) = zland 
    593             END SELECT 
    594             ! 
    595          END SELECT 
    596          !                                     ! North-South boundaries 
    597          !                                     ! ====================== 
    598          ! Nothing to do for the north fold, there is no ice shelf along this line. 
    599          ! 
    600       END IF 
    601       ! 
    602    END SUBROUTINE 
     283!!gm end 
    603284 
    604285#endif 
    605286 
    606287   !!====================================================================== 
     288   !!   identical routines in both distributed and shared memory computing 
     289   !!====================================================================== 
     290 
     291   !!---------------------------------------------------------------------- 
     292   !!                   ***   load_ptr_(2,3,4)d   *** 
     293   !! 
     294   !!   * Dummy Argument : 
     295   !!       in    ==>   ptab       ! array to be loaded (2D, 3D or 4D) 
     296   !!                   cd_nat     ! nature of pt2d array grid-points 
     297   !!                   psgn       ! sign used across the north fold boundary 
     298   !!       inout <=>   ptab_ptr   ! array of 2D, 3D or 4D pointers 
     299   !!                   cdna_ptr   ! nature of ptab array grid-points 
     300   !!                   psgn_ptr   ! sign used across the north fold boundary 
     301   !!                   kfld       ! number of elements that has been attributed 
     302   !!---------------------------------------------------------------------- 
     303 
     304   !!---------------------------------------------------------------------- 
     305   !!                  ***   lbc_lnk_(2,3,4)d_multi   *** 
     306   !!                     ***   load_ptr_(2,3,4)d   *** 
     307   !! 
     308   !!   * Argument : dummy argument use in lbc_lnk_multi_... routines 
     309   !! 
     310   !!---------------------------------------------------------------------- 
     311 
     312#  define DIM_2d 
     313#     define ROUTINE_MULTI          lbc_lnk_2d_multi 
     314#     define ROUTINE_LOAD           load_ptr_2d 
     315#     include "lbc_lnk_multi_generic.h90" 
     316#     undef ROUTINE_MULTI 
     317#     undef ROUTINE_LOAD 
     318#  undef DIM_2d 
     319 
     320 
     321#  define DIM_3d 
     322#     define ROUTINE_MULTI          lbc_lnk_3d_multi 
     323#     define ROUTINE_LOAD           load_ptr_3d 
     324#     include "lbc_lnk_multi_generic.h90" 
     325#     undef ROUTINE_MULTI 
     326#     undef ROUTINE_LOAD 
     327#  undef DIM_3d 
     328 
     329 
     330#  define DIM_4d 
     331#     define ROUTINE_MULTI          lbc_lnk_4d_multi 
     332#     define ROUTINE_LOAD           load_ptr_4d 
     333#     include "lbc_lnk_multi_generic.h90" 
     334#     undef ROUTINE_MULTI 
     335#     undef ROUTINE_LOAD 
     336#  undef DIM_4d 
     337 
     338   !!====================================================================== 
    607339END MODULE lbclnk 
    608340 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r8215 r8586  
    1313   !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd) 
    1414   !!   lbc_nfd_2d    : lateral boundary condition: North fold treatment for a 2D arrays   (lbc_nfd) 
    15    !!   mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP 
    16    !!   mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP 
     15   !!   lbc_nfd_nogather       : generic interface for lbc_nfd_nogather_3d and  
     16   !!                            lbc_nfd_nogather_2d routines (designed for use 
     17   !!                            with ln_nnogather to avoid global width arrays 
     18   !!                            mpi all gather operations) 
    1719   !!---------------------------------------------------------------------- 
    1820   USE dom_oce        ! ocean space and time domain  
    … …  
    2325 
    2426   INTERFACE lbc_nfd 
    25       MODULE PROCEDURE   lbc_nfd_3d, lbc_nfd_2d 
     27      MODULE PROCEDURE   lbc_nfd_2d    , lbc_nfd_3d    , lbc_nfd_4d 
     28      MODULE PROCEDURE   lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 
    2629   END INTERFACE 
    2730   ! 
    28    INTERFACE mpp_lbc_nfd 
    29       MODULE PROCEDURE   mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 
     31   INTERFACE lbc_nfd_nogather 
     32!                        ! Currently only 4d array version is needed 
     33!     MODULE PROCEDURE   lbc_nfd_nogather_2d    , lbc_nfd_nogather_3d 
     34      MODULE PROCEDURE   lbc_nfd_nogather_4d 
     35!     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 
     36!     MODULE PROCEDURE   lbc_nfd_nogather_4d_ptr 
    3037   END INTERFACE 
    3138 
    32    PUBLIC   lbc_nfd       ! north fold conditions 
    33    PUBLIC   mpp_lbc_nfd   ! north fold conditions (parallel case) 
     39   TYPE, PUBLIC ::   PTR_2D   !: array of 2D pointers (also used in lib_mpp) 
     40      REAL(wp), DIMENSION (:,:)    , POINTER ::   pt2d 
     41   END TYPE PTR_2D 
     42   TYPE, PUBLIC ::   PTR_3D   !: array of 3D pointers (also used in lib_mpp) 
     43      REAL(wp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
     44   END TYPE PTR_3D 
     45   TYPE, PUBLIC ::   PTR_4D   !: array of 4D pointers (also used in lib_mpp) 
     46      REAL(wp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
     47   END TYPE PTR_4D 
     48 
     49   PUBLIC   lbc_nfd            ! north fold conditions 
     50   PUBLIC   lbc_nfd_nogather   ! north fold conditions (no allgather case) 
    3451 
    3552   INTEGER, PUBLIC, PARAMETER            ::   jpmaxngh = 3               !: 
    … …  
    4461CONTAINS 
    4562 
    46    SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn ) 
    47       !!---------------------------------------------------------------------- 
    48       !!                  ***  routine lbc_nfd_3d  *** 
    49       !! 
    50       !! ** Purpose :   3D lateral boundary condition : North fold treatment 
    51       !!              without processor exchanges.  
    52       !! 
    53       !! ** Method  :    
    54       !! 
    55       !! ** Action  :   pt3d with updated values along the north fold 
    56       !!---------------------------------------------------------------------- 
    57       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the boundary condition is applied 
    58       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-point 
    59       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold 
    60       ! 
    61       INTEGER  ::   ji, jk 
    62       INTEGER  ::   ijt, iju, ijpj, ijpjm1 
    63       !!---------------------------------------------------------------------- 
    64       ! 
    65       SELECT CASE ( jpni ) 
    66       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    67       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    68       END SELECT 
    69       ijpjm1 = ijpj-1 
    70  
    71       DO jk = 1, SIZE( pt3d, 3 ) 
    72          ! 
    73          SELECT CASE ( npolj ) 
    74          ! 
    75          CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    76             ! 
    77             SELECT CASE ( cd_type ) 
    78             CASE ( 'T' , 'W' )                         ! T-, W-point 
    79                DO ji = 2, jpiglo 
    80                   ijt = jpiglo-ji+2 
    81                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    82                END DO 
    83                pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk) 
    84                DO ji = jpiglo/2+1, jpiglo 
    85                   ijt = jpiglo-ji+2 
    86                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
    87                END DO 
    88             CASE ( 'U' )                               ! U-point 
    89                DO ji = 1, jpiglo-1 
    90                   iju = jpiglo-ji+1 
    91                   pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    92                END DO 
    93                pt3d(   1  ,ijpj,jk) = psgn * pt3d(    2   ,ijpj-2,jk) 
    94                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk)  
    95                DO ji = jpiglo/2, jpiglo-1 
    96                   iju = jpiglo-ji+1 
    97                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
    98                END DO 
    99             CASE ( 'V' )                               ! V-point 
    100                DO ji = 2, jpiglo 
    101                   ijt = jpiglo-ji+2 
    102                   pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    103                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk) 
    104                END DO 
    105                pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk)  
    106             CASE ( 'F' )                               ! F-point 
    107                DO ji = 1, jpiglo-1 
    108                   iju = jpiglo-ji+1 
    109                   pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    110                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk) 
    111                END DO 
    112                pt3d(   1  ,ijpj,jk) = psgn * pt3d(    2   ,ijpj-3,jk) 
    113                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk)  
    114             END SELECT 
    115             ! 
    116          CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    117             ! 
    118             SELECT CASE ( cd_type ) 
    119             CASE ( 'T' , 'W' )                         ! T-, W-point 
    120                DO ji = 1, jpiglo 
    121                   ijt = jpiglo-ji+1 
    122                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) 
    123                END DO 
    124             CASE ( 'U' )                               ! U-point 
    125                DO ji = 1, jpiglo-1 
    126                   iju = jpiglo-ji 
    127                   pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) 
    128                END DO 
    129                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk) 
    130             CASE ( 'V' )                               ! V-point 
    131                DO ji = 1, jpiglo 
    132                   ijt = jpiglo-ji+1 
    133                   pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    134                END DO 
    135                DO ji = jpiglo/2+1, jpiglo 
    136                   ijt = jpiglo-ji+1 
    137                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
    138                END DO 
    139             CASE ( 'F' )                               ! F-point 
    140                DO ji = 1, jpiglo-1 
    141                   iju = jpiglo-ji 
    142                   pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    143                END DO 
    144                pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk) 
    145                DO ji = jpiglo/2+1, jpiglo-1 
    146                   iju = jpiglo-ji 
    147                   pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
    148                END DO 
    149             END SELECT 
    150             ! 
    151          CASE DEFAULT                           ! *  closed : the code probably never go through 
    152             ! 
    153             SELECT CASE ( cd_type) 
    154             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    155                pt3d(:, 1  ,jk) = 0._wp 
    156                pt3d(:,ijpj,jk) = 0._wp 
    157             CASE ( 'F' )                               ! F-point 
    158                pt3d(:,ijpj,jk) = 0._wp 
    159             END SELECT 
    160             ! 
    161          END SELECT     !  npolj 
    162          ! 
    163       END DO 
    164       ! 
    165    END SUBROUTINE lbc_nfd_3d 
    166  
    167  
    168    SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj ) 
     63   !!---------------------------------------------------------------------- 
     64   !!                   ***  routine lbc_nfd_(2,3,4)d  *** 
     65   !!---------------------------------------------------------------------- 
     66   !! 
     67   !! ** Purpose :   lateral boundary condition  
     68   !!                North fold treatment without processor exchanges.  
     69   !! 
     70   !! ** Method  :    
     71   !! 
     72   !! ** Action  :   ptab with updated values along the north fold 
     73   !!---------------------------------------------------------------------- 
     74   ! 
     75   !                       !==  2D array and array of 2D pointer  ==! 
     76   ! 
     77#  define DIM_2d 
     78#     define ROUTINE_NFD           lbc_nfd_2d 
     79#     include "lbc_nfd_generic.h90" 
     80#     undef ROUTINE_NFD 
     81#     define MULTI 
     82#     define ROUTINE_NFD           lbc_nfd_2d_ptr 
     83#     include "lbc_nfd_generic.h90" 
     84#     undef ROUTINE_NFD 
     85#     undef MULTI 
     86#  undef DIM_2d 
     87   ! 
     88   !                       !==  3D array and array of 3D pointer  ==! 
     89   ! 
     90#  define DIM_3d 
     91#     define ROUTINE_NFD           lbc_nfd_3d 
     92#     include "lbc_nfd_generic.h90" 
     93#     undef ROUTINE_NFD 
     94#     define MULTI 
     95#     define ROUTINE_NFD           lbc_nfd_3d_ptr 
     96#     include "lbc_nfd_generic.h90" 
     97#     undef ROUTINE_NFD 
     98#     undef MULTI 
     99#  undef DIM_3d 
     100   ! 
     101   !                       !==  4D array and array of 4D pointer  ==! 
     102   ! 
     103#  define DIM_4d 
     104#     define ROUTINE_NFD           lbc_nfd_4d 
     105#     include "lbc_nfd_generic.h90" 
     106#     undef ROUTINE_NFD 
     107#     define MULTI 
     108#     define ROUTINE_NFD           lbc_nfd_4d_ptr 
     109#     include "lbc_nfd_generic.h90" 
     110#     undef ROUTINE_NFD 
     111#     undef MULTI 
     112#  undef DIM_4d 
     113   ! 
     114   !  lbc_nfd_nogather routines 
     115   ! 
     116   !                       !==  2D array and array of 2D pointer  ==! 
     117   ! 
     118!#  define DIM_2d 
     119!#     define ROUTINE_NFD           lbc_nfd_nogather_2d 
     120!#     include "lbc_nfd_nogather_generic.h90" 
     121!#     undef ROUTINE_NFD 
     122!#     define MULTI 
     123!#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr 
     124!#     include "lbc_nfd_nogather_generic.h90" 
     125!#     undef ROUTINE_NFD 
     126!#     undef MULTI 
     127!#  undef DIM_2d 
     128   ! 
     129   !                       !==  3D array and array of 3D pointer  ==! 
     130   ! 
     131!#  define DIM_3d 
     132!#     define ROUTINE_NFD           lbc_nfd_nogather_3d 
     133!#     include "lbc_nfd_nogather_generic.h90" 
     134!#     undef ROUTINE_NFD 
     135!#     define MULTI 
     136!#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr 
     137!#     include "lbc_nfd_nogather_generic.h90" 
     138!#     undef ROUTINE_NFD 
     139!#     undef MULTI 
     140!#  undef DIM_3d 
     141   ! 
     142   !                       !==  4D array and array of 4D pointer  ==! 
     143   ! 
     144#  define DIM_4d 
     145#     define ROUTINE_NFD           lbc_nfd_nogather_4d 
     146#     include "lbc_nfd_nogather_generic.h90" 
     147#     undef ROUTINE_NFD 
     148!#     define MULTI 
     149!#     define ROUTINE_NFD           lbc_nfd_nogather_4d_ptr 
     150!#     include "lbc_nfd_nogather_generic.h90" 
     151!#     undef ROUTINE_NFD 
     152!#     undef MULTI 
     153#  undef DIM_4d 
     154 
     155   !!---------------------------------------------------------------------- 
     156 
     157 
     158!!gm   CAUTION HERE  optional pr2dj  not implemented in generic case 
     159!!gm                 furthermore, in the _org routine it is OK only for T-point pivot !! 
     160 
     161 
     162   SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj ) 
    169163      !!---------------------------------------------------------------------- 
    170164      !!                  ***  routine lbc_nfd_2d  *** 
    … …  
    178172      !!---------------------------------------------------------------------- 
    179173      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied 
    180       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-point 
     174      CHARACTER(len=1)        , INTENT(in   ) ::   cd_nat   ! nature of pt2d grid-point 
    181175      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold 
    182176      INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos 
    … …  
    205199      CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    206200         ! 
    207          SELECT CASE ( cd_type ) 
     201         SELECT CASE ( cd_nat ) 
    208202         ! 
    209203         CASE ( 'T' , 'W' )                               ! T- , W-points 
    … …  
    264258      CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    265259         ! 
    266          SELECT CASE ( cd_type ) 
     260         SELECT CASE ( cd_nat ) 
    267261         CASE ( 'T' , 'W' )                               ! T-, W-point 
    268262            DO jl = 0, ipr2dj 
    … …  
    315309      CASE DEFAULT                           ! *  closed : the code probably never go through 
    316310         ! 
    317          SELECT CASE ( cd_type) 
     311         SELECT CASE ( cd_nat) 
    318312         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    319313            pt2d(:, 1:1-ipr2dj     ) = 0._wp 
    … …  
    328322      END SELECT 
    329323      ! 
    330    END SUBROUTINE lbc_nfd_2d 
    331  
    332  
    333    SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 
    334       !!---------------------------------------------------------------------- 
    335       !!                  ***  routine mpp_lbc_nfd_3d  *** 
    336       !! 
    337       !! ** Purpose :   3D lateral boundary condition : North fold treatment 
    338       !!              without processor exchanges.  
    339       !! 
    340       !! ** Method  :    
    341       !! 
    342       !! ** Action  :   pt3d with updated values along the north fold 
    343       !!---------------------------------------------------------------------- 
    344       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3dl     ! 3D array on which the boundary condition is applied 
    345       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pt3dr     ! 3D array on which the boundary condition is applied 
    346       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d(l/r) grid-point 
    347       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold 
    348       ! 
    349       INTEGER  ::   ji, jk      ! dummy loop indices 
    350       INTEGER  ::   ipk         ! 3rd dimension of the input array 
    351       INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
    352       !!---------------------------------------------------------------------- 
    353       ! 
    354       ipk = SIZE( pt3dl, 3 ) 
    355       ! 
    356       SELECT CASE ( jpni ) 
    357       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    358       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    359       END SELECT 
    360       ijpjm1 = ijpj-1 
    361       ! 
    362       ! 
    363       SELECT CASE ( npolj ) 
    364       ! 
    365       CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    366          ! 
    367          SELECT CASE ( cd_type ) 
    368             CASE ( 'T' , 'W' )                         ! T-, W-point 
    369                IF ( nimpp /= 1 ) THEN   ;   startloop = 1 
    370                ELSE                     ;   startloop = 2 
    371                ENDIF 
    372                ! 
    373                DO jk = 1, ipk 
    374                   DO ji = startloop, nlci 
    375                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    376                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    377                   END DO 
    378                   IF(nimpp .eq. 1) THEN 
    379                      pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk) 
    380                   ENDIF 
    381                END DO 
    382  
    383                IF( nimpp >= jpiglo/2+1 ) THEN 
    384                  startloop = 1 
    385                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    386                  startloop = jpiglo/2+1 - nimpp + 1 
    387                ELSE 
    388                  startloop = nlci + 1 
    389                ENDIF 
    390                IF(startloop <= nlci) THEN 
    391                  DO jk = 1, ipk 
    392                     DO ji = startloop, nlci 
    393                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    394                        jia = ji + nimpp - 1 
    395                        ijta = jpiglo - jia + 2 
    396                        IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
    397                           pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 
    398                        ELSE 
    399                           pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
    400                        ENDIF 
    401                     END DO 
    402                  END DO 
    403                ENDIF 
    404                ! 
    405             CASE ( 'U' )                               ! U-point 
    406                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    407                   endloop = nlci 
    408                ELSE 
    409                   endloop = nlci - 1 
    410                ENDIF 
    411                DO jk = 1, ipk 
    412                   DO ji = 1, endloop 
    413                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    414                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    415                   END DO 
    416                   IF(nimpp .eq. 1) THEN 
    417                      pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-2,jk) 
    418                   ENDIF 
    419                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    420                      pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk) 
    421                   ENDIF 
    422                END DO 
    423                ! 
    424                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    425                   endloop = nlci 
    426                ELSE 
    427                   endloop = nlci - 1 
    428                ENDIF 
    429                IF( nimpp >= jpiglo/2 ) THEN 
    430                   startloop = 1 
    431                ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 
    432                   startloop = jpiglo/2 - nimpp + 1 
    433                ELSE 
    434                   startloop = endloop + 1 
    435                ENDIF 
    436                IF( startloop <= endloop ) THEN 
    437                  DO jk = 1, ipk 
    438                     DO ji = startloop, endloop 
    439                       iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    440                       jia = ji + nimpp - 1 
    441                       ijua = jpiglo - jia + 1 
    442                       IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
    443                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 
    444                       ELSE 
    445                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
    446                       ENDIF 
    447                     END DO 
    448                  END DO 
    449                ENDIF 
    450                ! 
    451             CASE ( 'V' )                               ! V-point 
    452                IF( nimpp /= 1 ) THEN 
    453                   startloop = 1 
    454                ELSE 
    455                   startloop = 2 
    456                ENDIF 
    457                DO jk = 1, ipk 
    458                   DO ji = startloop, nlci 
    459                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    460                      pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    461                      pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 
    462                   END DO 
    463                   IF(nimpp .eq. 1) THEN 
    464                      pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk) 
    465                   ENDIF 
    466                END DO 
    467             CASE ( 'F' )                               ! F-point 
    468                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    469                   endloop = nlci 
    470                ELSE 
    471                   endloop = nlci - 1 
    472                ENDIF 
    473                DO jk = 1, ipk 
    474                   DO ji = 1, endloop 
    475                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    476                      pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    477                      pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 
    478                   END DO 
    479                   IF(nimpp .eq. 1) THEN 
    480                      pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-3,jk) 
    481                   ENDIF 
    482                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    483                      pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk) 
    484                   ENDIF 
    485                END DO 
    486          END SELECT 
    487          ! 
    488       CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    489          ! 
    490          SELECT CASE ( cd_type ) 
    491             CASE ( 'T' , 'W' )                         ! T-, W-point 
    492                DO jk = 1, ipk 
    493                   DO ji = 1, nlci 
    494                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    495                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 
    496                   END DO 
    497                END DO 
    498                ! 
    499             CASE ( 'U' )                               ! U-point 
    500                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    501                   endloop = nlci 
    502                ELSE 
    503                   endloop = nlci - 1 
    504                ENDIF 
    505                DO jk = 1, ipk 
    506                   DO ji = 1, endloop 
    507                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    508                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 
    509                   END DO 
    510                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    511                      pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk) 
    512                   ENDIF 
    513                END DO 
    514                ! 
    515             CASE ( 'V' )                               ! V-point 
    516                DO jk = 1, ipk 
    517                   DO ji = 1, nlci 
    518                      ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 
    519                      pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
    520                   END DO 
    521                END DO 
    522                ! 
    523                IF( nimpp >= jpiglo/2+1 ) THEN 
    524                   startloop = 1 
    525                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    526                   startloop = jpiglo/2+1 - nimpp + 1 
    527                ELSE 
    528                   startloop = nlci + 1 
    529                ENDIF 
    530                IF( startloop <= nlci ) THEN 
    531                  DO jk = 1, ipk 
    532                     DO ji = startloop, nlci 
    533                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    534                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
    535                     END DO 
    536                  END DO 
    537                ENDIF 
    538                ! 
    539             CASE ( 'F' )                               ! F-point 
    540                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    541                   endloop = nlci 
    542                ELSE 
    543                   endloop = nlci - 1 
    544                ENDIF 
    545                DO jk = 1, ipk 
    546                   DO ji = 1, endloop 
    547                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    548                      pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
    549                   END DO 
    550                   IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    551                      pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk) 
    552                   ENDIF 
    553                END DO 
    554                ! 
    555                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    556                   endloop = nlci 
    557                ELSE 
    558                   endloop = nlci - 1 
    559                ENDIF 
    560                IF( nimpp >= jpiglo/2+1 ) THEN 
    561                   startloop = 1 
    562                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    563                   startloop = jpiglo/2+1 - nimpp + 1 
    564                ELSE 
    565                   startloop = endloop + 1 
    566                ENDIF 
    567                IF( startloop <= endloop ) THEN 
    568                   DO jk = 1, ipk 
    569                      DO ji = startloop, endloop 
    570                         iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    571                         pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
    572                      END DO 
    573                   END DO 
    574                ENDIF 
    575                ! 
    576          END SELECT 
    577          ! 
    578       CASE DEFAULT                           ! *  closed : the code probably never go through 
    579          ! 
    580          SELECT CASE ( cd_type) 
    581             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    582                pt3dl(:, 1  ,jk) = 0._wp 
    583                pt3dl(:,ijpj,jk) = 0._wp 
    584             CASE ( 'F' )                               ! F-point 
    585                pt3dl(:,ijpj,jk) = 0._wp 
    586          END SELECT 
    587          ! 
    588       END SELECT     !  npolj 
    589       ! 
    590    END SUBROUTINE mpp_lbc_nfd_3d 
    591  
    592  
    593    SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 
    594       !!---------------------------------------------------------------------- 
    595       !!                  ***  routine mpp_lbc_nfd_2d  *** 
    596       !! 
    597       !! ** Purpose :   2D lateral boundary condition : North fold treatment 
    598       !!              without processor exchanges.  
    599       !! 
    600       !! ** Method  :    
    601       !! 
    602       !! ** Action  :   pt2dl with updated values along the north fold 
    603       !!---------------------------------------------------------------------- 
    604       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2dl     ! 2D array on which the boundary condition is applied 
    605       REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pt2dr     ! 2D array on which the boundary condition is applied 
    606       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d(l/r) grid-point 
    607       REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold 
    608       ! 
    609       INTEGER  ::   ji 
    610       INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
    611       !!---------------------------------------------------------------------- 
    612  
    613       SELECT CASE ( jpni ) 
    614       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    615       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    616       END SELECT 
    617       ! 
    618       ijpjm1 = ijpj-1 
    619       ! 
    620       ! 
    621       SELECT CASE ( npolj ) 
    622       ! 
    623       CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    624          ! 
    625          SELECT CASE ( cd_type ) 
    626          ! 
    627          CASE ( 'T' , 'W' )                               ! T- , W-points 
    628             IF( nimpp /= 1 ) THEN 
    629               startloop = 1 
    630             ELSE 
    631               startloop = 2 
    632             ENDIF 
    633             DO ji = startloop, nlci 
    634               ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    635               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    636             END DO 
    637             IF( nimpp == 1 ) THEN 
    638               pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2) 
    639             ENDIF 
    640             ! 
    641             IF( nimpp >= jpiglo/2+1 ) THEN 
    642                startloop = 1 
    643             ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    644                startloop = jpiglo/2+1 - nimpp + 1 
    645             ELSE 
    646                startloop = nlci + 1 
    647             ENDIF 
    648             DO ji = startloop, nlci 
    649                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    650                jia = ji + nimpp - 1 
    651                ijta = jpiglo - jia + 2 
    652                IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
    653                   pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 
    654                ELSE 
    655                   pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
    656                ENDIF 
    657             END DO 
    658             ! 
    659          CASE ( 'U' )                                     ! U-point 
    660             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    661                endloop = nlci 
    662             ELSE 
    663                endloop = nlci - 1 
    664             ENDIF 
    665             DO ji = 1, endloop 
    666                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    667                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    668             END DO 
    669             ! 
    670             IF (nimpp .eq. 1) THEN 
    671               pt2dl(   1  ,ijpj  ) = psgn * pt2dl(    2   ,ijpj-2) 
    672               pt2dl(1     ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1) 
    673             ENDIF 
    674             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    675               pt2dl(nlci,ijpj  ) = psgn * pt2dl(nlci-1,ijpj-2) 
    676             ENDIF 
    677             ! 
    678             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    679                endloop = nlci 
    680             ELSE 
    681                endloop = nlci - 1 
    682             ENDIF 
    683             IF( nimpp >= jpiglo/2 ) THEN 
    684                startloop = 1 
    685             ELSEIF( nimpp+nlci-1 >= jpiglo/2 .AND. nimpp < jpiglo/2 ) THEN 
    686                startloop = jpiglo/2 - nimpp + 1 
    687             ELSE 
    688                startloop = endloop + 1 
    689             ENDIF 
    690             DO ji = startloop, endloop 
    691                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    692                jia = ji + nimpp - 1 
    693                ijua = jpiglo - jia + 1 
    694                IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
    695                   pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 
    696                ELSE 
    697                   pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
    698                ENDIF 
    699             END DO 
    700             ! 
    701          CASE ( 'V' )                                     ! V-point 
    702             IF( nimpp /= 1 ) THEN 
    703               startloop = 1 
    704             ELSE 
    705               startloop = 2 
    706             ENDIF 
    707             DO ji = startloop, nlci 
    708               ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    709               pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 
    710               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 
    711             END DO 
    712             IF (nimpp .eq. 1) THEN 
    713               pt2dl( 1 ,ijpj)   = psgn * pt2dl( 3 ,ijpj-3)  
    714             ENDIF 
    715             ! 
    716          CASE ( 'F' )                                     ! F-point 
    717             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    718                endloop = nlci 
    719             ELSE 
    720                endloop = nlci - 1 
    721             ENDIF 
    722             DO ji = 1, endloop 
    723                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    724                pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 
    725                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 
    726             END DO 
    727             IF (nimpp .eq. 1) THEN 
    728               pt2dl(   1  ,ijpj)   = psgn * pt2dl(    2   ,ijpj-3) 
    729               pt2dl(   1  ,ijpj-1) = psgn * pt2dl(    2   ,ijpj-2) 
    730             ENDIF 
    731             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    732               pt2dl(nlci,ijpj)   = psgn * pt2dl(nlci-1,ijpj-3) 
    733               pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2)  
    734             ENDIF 
    735             ! 
    736          CASE ( 'I' )                                     ! ice U-V point (I-point) 
    737             IF( nimpp /= 1 ) THEN 
    738                startloop = 1 
    739             ELSE 
    740                startloop = 3 
    741                pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
    742             ENDIF 
    743             DO ji = startloop, nlci 
    744                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 
    745                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    746             END DO 
    747             ! 
    748          END SELECT 
    749          ! 
    750       CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    751          ! 
    752          SELECT CASE ( cd_type ) 
    753          CASE ( 'T' , 'W' )                               ! T-, W-point 
    754             DO ji = 1, nlci 
    755                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    756                pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 
    757             END DO 
    758             ! 
    759          CASE ( 'U' )                                     ! U-point 
    760             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    761                endloop = nlci 
    762             ELSE 
    763                endloop = nlci - 1 
    764             ENDIF 
    765             DO ji = 1, endloop 
    766                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    767                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
    768             END DO 
    769             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    770                pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 
    771             ENDIF 
    772             ! 
    773          CASE ( 'V' )                                     ! V-point 
    774             DO ji = 1, nlci 
    775                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    776                pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
    777             END DO 
    778             IF( nimpp >= jpiglo/2+1 ) THEN 
    779                startloop = 1 
    780             ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    781                startloop = jpiglo/2+1 - nimpp + 1 
    782             ELSE 
    783                startloop = nlci + 1 
    784             ENDIF 
    785             DO ji = startloop, nlci 
    786                ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    787                pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
    788             END DO 
    789             ! 
    790          CASE ( 'F' )                               ! F-point 
    791             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    792                endloop = nlci 
    793             ELSE 
    794                endloop = nlci - 1 
    795             ENDIF 
    796             DO ji = 1, endloop 
    797                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    798                pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
    799             END DO 
    800             IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    801                 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 
    802             ENDIF 
    803             ! 
    804             IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    805                endloop = nlci 
    806             ELSE 
    807                endloop = nlci - 1 
    808             ENDIF 
    809             IF( nimpp >= jpiglo/2+1 ) THEN 
    810                startloop = 1 
    811             ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    812                startloop = jpiglo/2+1 - nimpp + 1 
    813             ELSE 
    814                startloop = endloop + 1 
    815             ENDIF 
    816             ! 
    817             DO ji = startloop, endloop 
    818                iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    819                pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
    820             END DO 
    821             ! 
    822          CASE ( 'I' )                                  ! ice U-V point (I-point) 
    823                IF( nimpp /= 1 ) THEN 
    824                   startloop = 1 
    825                ELSE 
    826                   startloop = 2 
    827                ENDIF 
    828                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    829                   endloop = nlci 
    830                ELSE 
    831                   endloop = nlci - 1 
    832                ENDIF 
    833                DO ji = startloop , endloop 
    834                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    835                   pt2dl(ji,ijpj) = 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
    836                END DO 
    837                ! 
    838          END SELECT 
    839          ! 
    840       CASE DEFAULT                           ! *  closed : the code probably never go through 
    841          ! 
    842          SELECT CASE ( cd_type) 
    843          CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    844             pt2dl(:, 1  ) = 0._wp 
    845             pt2dl(:,ijpj) = 0._wp 
    846          CASE ( 'F' )                                   ! F-point 
    847             pt2dl(:,ijpj) = 0._wp 
    848          CASE ( 'I' )                                   ! ice U-V point 
    849             pt2dl(:, 1  ) = 0._wp 
    850             pt2dl(:,ijpj) = 0._wp 
    851          END SELECT 
    852          ! 
    853       END SELECT 
    854       ! 
    855    END SUBROUTINE mpp_lbc_nfd_2d 
     324   END SUBROUTINE lbc_nfd_2d_org 
    856325 
    857326   !!====================================================================== 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r8568 r8586  
    1919   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl 
    2020   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager 
    21    !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d',  
    22    !!                          'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 
    23    !!                          the mppobc routine to optimize the BDY and OBC communications 
    24    !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables  
     21   !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm. 
     22   !!            3.5  !  2013  (C. Ethe, G. Madec)  message passing arrays as local variables  
    2523   !!            3.5  !  2013  (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 
    2624   !!            3.6  !  2015  (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max 
    2725   !!            4.0  !  2017  (G. Madec) automatique allocation of array argument (use any 3rd dimension) 
     26   !!             -   !  2017  (G. Madec) create generic.h90 files to generate all lbc and north fold routines 
    2827   !!---------------------------------------------------------------------- 
    2928 
    … …  
    4241   !!   mynode        : indentify the processor unit 
    4342   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 
    44    !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays 
    4543   !!   mpp_lnk_e     : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 
    4644   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 
    … …  
    5755   !!   mppstop       : 
    5856   !!   mpp_ini_north : initialisation of north fold 
    59    !!   mpp_lbc_north : north fold processors gathering 
     57!!gm   !!   mpp_lbc_north : north fold processors gathering 
    6058   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 
    6159   !!   mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 
    … …  
    6866   IMPLICIT NONE 
    6967   PRIVATE 
    70     
     68 
     69   INTERFACE mpp_nfd 
     70      MODULE PROCEDURE   mpp_nfd_2d      , mpp_nfd_3d      , mpp_nfd_4d 
     71      MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     72   END INTERFACE 
     73 
     74   ! Interface associated to the mpp_lnk_... routines is defined in lbclnk 
     75   PUBLIC   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d 
     76   PUBLIC   mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 
     77   PUBLIC   mpp_lnk_2d_e 
     78   ! 
     79!!gm  this should be useless 
     80   PUBLIC   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
     81   PUBLIC   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     82!!gm end 
     83   ! 
    7184   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 
    7285   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
    73    PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
     86   PUBLIC   mpp_ini_north, mpp_lbc_north_e 
     87!!gm   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
     88   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    7489   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    7590   PUBLIC   mpp_max_multiple 
    76    PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    77    PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    78    PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
     91!!gm   PUBLIC   mpp_lnk_2d_9  
     92!!gm   PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    7993   PUBLIC   mppscatter, mppgather 
    8094   PUBLIC   mpp_ini_ice, mpp_ini_znl 
    … …  
    8296   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    8397   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    84    PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    8598   PUBLIC   mpprank 
    86  
    87    TYPE arrayptr 
    88       REAL(wp), DIMENSION (:,:),  POINTER ::   pt2d 
    89    END TYPE arrayptr 
    90    ! 
    91    PUBLIC   arrayptr 
    9299    
    93100   !! * Interfaces 
    … …  
    105112         &             mppsum_realdd, mppsum_a_realdd 
    106113   END INTERFACE 
    107    INTERFACE mpp_lbc_north 
    108       MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
    109    END INTERFACE 
     114!!gm   INTERFACE mpp_lbc_north 
     115!!gm      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
     116!!gm   END INTERFACE 
    110117   INTERFACE mpp_minloc 
    111118      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
    … …  
    138145 
    139146   ! variables used in case of sea-ice 
    140    INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in limthd) 
     147   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in icethd) 
    141148   INTEGER         ::   ngrp_iworld     !  group ID for the world processors (for rheology) 
    142149   INTEGER         ::   ngrp_ice        !  group ID for the ice processors (for rheology) 
    … …  
    327334   END FUNCTION mynode 
    328335 
    329  
    330    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    331       !!---------------------------------------------------------------------- 
    332       !!                  ***  routine mpp_lnk_3d  *** 
    333       !! 
    334       !! ** Purpose :   Message passing manadgement 
    335       !! 
    336       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    337       !!              between processors following neighboring subdomains. 
    338       !!                domain parameters 
    339       !!                    nlci   : first dimension of the local subdomain 
    340       !!                    nlcj   : second dimension of the local subdomain 
    341       !!                    nbondi : mark for "east-west local boundary" 
    342       !!                    nbondj : mark for "north-south local boundary" 
    343       !!                    noea   : number for local neighboring processors 
    344       !!                    nowe   : number for local neighboring processors 
    345       !!                    noso   : number for local neighboring processors 
    346       !!                    nono   : number for local neighboring processors 
    347       !! 
    348       !! ** Action  :   ptab with update value at its periphery 
    349       !!---------------------------------------------------------------------- 
    350       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    351       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    352       REAL(wp)                  , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    353       CHARACTER(len=3), OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    354       REAL(wp)        , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    355       ! 
    356       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    357       INTEGER  ::   ipk                        ! 3rd dimension of the input array 
    358       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    359       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    360       REAL(wp) ::   zland 
    361       INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend 
    362       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    363       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    364       !!---------------------------------------------------------------------- 
    365       ! 
    366       ipk = SIZE( ptab, 3 ) 
    367       ! 
    368       ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2),   & 
    369          &      zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2)  ) 
    370  
    371       ! 
    372       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    373       ELSE                         ;   zland = 0._wp     ! zero by default 
    374       ENDIF 
    375  
    376       ! 1. standard boundary treatment 
    377       ! ------------------------------ 
    378       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    379          ! 
    380          ! WARNING ptab is defined only between nld and nle 
    381          DO jk = 1, ipk 
    382             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    383                ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk) 
    384                ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
    385                ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
    386             END DO 
    387             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    388                ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
    389                ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
    390                ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
    391             END DO 
    392          END DO 
    393          ! 
    394       ELSE                              ! standard close or cyclic treatment 
    395          ! 
    396          !                                   ! East-West boundaries 
    397          !                                        !* Cyclic 
    398          IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    399             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    400             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    401          ELSE                                     !* closed 
    402             IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
    403                                          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
    404          ENDIF 
    405          !                                   ! North-South boundaries 
    406          !                                        !* cyclic (only with no mpp j-split) 
    407          IF( nbondj == 2 .AND. jperio == 7 ) THEN  
    408             ptab(:,1 , :) = ptab(:, jpjm1,:) 
    409             ptab(:,jpj,:) = ptab(:,     2,:) 
    410          ELSE                                     !* closed 
    411             IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
    412                                          ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    413          ENDIF 
    414          ! 
    415       ENDIF 
    416  
    417       ! 2. East and west directions exchange 
    418       ! ------------------------------------ 
    419       ! we play with the neigbours AND the row number because of the periodicity 
    420       ! 
    421       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    422       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    423          iihom = nlci-nreci 
    424          DO jl = 1, jpreci 
    425             zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
    426             zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
    427          END DO 
    428       END SELECT 
    429       ! 
    430       !                           ! Migrations 
    431       imigr = jpreci * jpj * ipk 
    432       ! 
    433       SELECT CASE ( nbondi ) 
    434       CASE ( -1 ) 
    435          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    436          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    437          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    438       CASE ( 0 ) 
    439          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    440          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    441          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    442          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    443          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    444          IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    445       CASE ( 1 ) 
    446          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    447          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    448          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    449       END SELECT 
    450       ! 
    451       !                           ! Write Dirichlet lateral conditions 
    452       iihom = nlci-jpreci 
    453       ! 
    454       SELECT CASE ( nbondi ) 
    455       CASE ( -1 ) 
    456          DO jl = 1, jpreci 
    457             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    458          END DO 
    459       CASE ( 0 ) 
    460          DO jl = 1, jpreci 
    461             ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
    462             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    463          END DO 
    464       CASE ( 1 ) 
    465          DO jl = 1, jpreci 
    466             ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
    467          END DO 
    468       END SELECT 
    469  
    470       ! 3. North and south directions 
    471       ! ----------------------------- 
    472       ! always closed : we play only with the neigbours 
    473       ! 
    474       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    475          ijhom = nlcj-nrecj 
    476          DO jl = 1, jprecj 
    477             zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
    478             zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
    479          END DO 
    480       ENDIF 
    481       ! 
    482       !                           ! Migrations 
    483       imigr = jprecj * jpi * ipk 
    484       ! 
    485       SELECT CASE ( nbondj ) 
    486       CASE ( -1 ) 
    487          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    488          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    489          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    490       CASE ( 0 ) 
    491          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    492          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    493          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    494          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    495          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    496          IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err ) 
    497       CASE ( 1 ) 
    498          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    499          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    500          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    501       END SELECT 
    502       ! 
    503       !                           ! Write Dirichlet lateral conditions 
    504       ijhom = nlcj-jprecj 
    505       ! 
    506       SELECT CASE ( nbondj ) 
    507       CASE ( -1 ) 
    508          DO jl = 1, jprecj 
    509             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    510          END DO 
    511       CASE ( 0 ) 
    512          DO jl = 1, jprecj 
    513             ptab(:,jl      ,:) = zt3sn(:,jl,:,2) 
    514             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    515          END DO 
    516       CASE ( 1 ) 
    517          DO jl = 1, jprecj 
    518             ptab(:,jl,:) = zt3sn(:,jl,:,2) 
    519          END DO 
    520       END SELECT 
    521  
    522       ! 4. north fold treatment 
    523       ! ----------------------- 
    524       ! 
    525       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    526          ! 
    527          SELECT CASE ( jpni ) 
    528          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    529          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    530          END SELECT 
    531          ! 
    532       ENDIF 
    533       ! 
    534       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
    535       ! 
    536    END SUBROUTINE mpp_lnk_3d 
    537  
    538  
    539    SUBROUTINE mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp, pval ) 
    540       !!---------------------------------------------------------------------- 
    541       !!                  ***  routine mpp_lnk_2d_multiple  *** 
    542       !! 
    543       !! ** Purpose :   Message passing management for multiple 2d arrays 
    544       !! 
    545       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    546       !!      between processors following neighboring subdomains. 
    547       !!            domain parameters 
    548       !!                    nlci   : first dimension of the local subdomain 
    549       !!                    nlcj   : second dimension of the local subdomain 
    550       !!                    nbondi : mark for "east-west local boundary" 
    551       !!                    nbondj : mark for "north-south local boundary" 
    552       !!                    noea   : number for local neighboring processors 
    553       !!                    nowe   : number for local neighboring processors 
    554       !!                    noso   : number for local neighboring processors 
    555       !!                    nono   : number for local neighboring processors 
    556       !!---------------------------------------------------------------------- 
    557       TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields  
    558       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! nature of pt2d_array grid-points 
    559       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! sign used across the north fold boundary 
    560       INTEGER                       , INTENT(in   ) ::   kfld         ! number of pt2d arrays 
    561       CHARACTER(len=3), OPTIONAL    , INTENT(in   ) ::   cd_mpp       ! fill the overlap area only 
    562       REAL(wp)        , OPTIONAL    , INTENT(in   ) ::   pval         ! background value (used at closed boundaries) 
    563       ! 
    564       INTEGER  ::   ji, jj, jl, jf   ! dummy loop indices 
    565       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    566       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    567       REAL(wp) ::   zland 
    568       INTEGER , DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat       ! for key_mpi_isend 
    569       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    570       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    571       !!---------------------------------------------------------------------- 
    572       ! 
    573       ALLOCATE( zt2ns(jpi,jprecj,2*kfld), zt2sn(jpi,jprecj,2*kfld),  & 
    574          &      zt2ew(jpj,jpreci,2*kfld), zt2we(jpj,jpreci,2*kfld)   ) 
    575       ! 
    576       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    577       ELSE                         ;   zland = 0._wp     ! zero by default 
    578       ENDIF 
    579  
    580       ! 1. standard boundary treatment 
    581       ! ------------------------------ 
    582       ! 
    583       !First Array 
    584       DO jf = 1 , kfld 
    585          IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    586             ! 
    587             ! WARNING pt2d is defined only between nld and nle 
    588             DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    589                pt2d_array(jf)%pt2d(nldi  :nlei  , jj) = pt2d_array(jf)%pt2d(nldi:nlei, nlej) 
    590                pt2d_array(jf)%pt2d(1     :nldi-1, jj) = pt2d_array(jf)%pt2d(nldi     , nlej) 
    591                pt2d_array(jf)%pt2d(nlei+1:nlci  , jj) = pt2d_array(jf)%pt2d(     nlei, nlej)  
    592             END DO 
    593             DO ji = nlci+1, jpi                 ! added column(s) (full) 
    594                pt2d_array(jf)%pt2d(ji, nldj  :nlej  ) = pt2d_array(jf)%pt2d(nlei, nldj:nlej) 
    595                pt2d_array(jf)%pt2d(ji, 1     :nldj-1) = pt2d_array(jf)%pt2d(nlei, nldj     ) 
    596                pt2d_array(jf)%pt2d(ji, nlej+1:jpj   ) = pt2d_array(jf)%pt2d(nlei,      nlej) 
    597             END DO 
    598             ! 
    599          ELSE                              ! standard close or cyclic treatment 
    600             ! 
    601             !                                   ! East-West boundaries 
    602             IF( nbondi == 2 .AND.   &                !* Cyclic 
    603                &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    604                pt2d_array(jf)%pt2d(  1  , : ) = pt2d_array(jf)%pt2d( jpim1, : )                             ! west 
    605                pt2d_array(jf)%pt2d( jpi , : ) = pt2d_array(jf)%pt2d(   2  , : )                             ! east 
    606             ELSE                                     !* Closed 
    607                IF( .NOT. type_array(jf) == 'F' )   pt2d_array(jf)%pt2d(            1 : jpreci,:) = zland    ! south except F-point 
    608                                                    pt2d_array(jf)%pt2d(nlci-jpreci+1 : jpi   ,:) = zland    ! north 
    609             ENDIF 
    610             !                                   ! North-South boundaries 
    611             !                                        !* Cyclic 
    612             IF( nbondj == 2 .AND. jperio == 7 ) THEN 
    613                pt2d_array(jf)%pt2d(:,  1  ) =   pt2d_array(jf)%pt2d(:, jpjm1 ) 
    614                pt2d_array(jf)%pt2d(:, jpj ) =   pt2d_array(jf)%pt2d(:,   2   )           
    615             ELSE                                     !* Closed              
    616                IF( .NOT. type_array(jf) == 'F' )   pt2d_array(jf)%pt2d(:,             1:jprecj ) = zland    ! south except F-point 
    617                                                    pt2d_array(jf)%pt2d(:, nlcj-jprecj+1:jpj    ) = zland    ! north 
    618             ENDIF 
    619          ENDIF 
    620       END DO 
    621  
    622       ! 2. East and west directions exchange 
    623       ! ------------------------------------ 
    624       ! we play with the neigbours AND the row number because of the periodicity 
    625       ! 
    626       DO jf = 1 , kfld 
    627          SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    628          CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    629             iihom = nlci-nreci 
    630             DO jl = 1, jpreci 
    631                zt2ew( : , jl , jf ) = pt2d_array(jf)%pt2d( jpreci+jl , : ) 
    632                zt2we( : , jl , jf ) = pt2d_array(jf)%pt2d( iihom +jl , : ) 
    633             END DO 
    634          END SELECT 
    635       END DO 
    636       ! 
    637       !                           ! Migrations 
    638       imigr = jpreci * jpj 
    639       ! 
    640       SELECT CASE ( nbondi ) 
    641       CASE ( -1 ) 
    642          CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req1 ) 
    643          CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea ) 
    644          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    645       CASE ( 0 ) 
    646          CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 ) 
    647          CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req2 ) 
    648          CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea ) 
    649          CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe ) 
    650          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    651          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    652       CASE ( 1 ) 
    653          CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 ) 
    654          CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe ) 
    655          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    656       END SELECT 
    657       ! 
    658       !                           ! Write Dirichlet lateral conditions 
    659       iihom = nlci - jpreci 
    660       ! 
    661  
    662       DO jf = 1 , kfld 
    663          SELECT CASE ( nbondi ) 
    664          CASE ( -1 ) 
    665             DO jl = 1, jpreci 
    666                pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf) 
    667             END DO 
    668          CASE ( 0 ) 
    669             DO jl = 1, jpreci 
    670                pt2d_array(jf)%pt2d(       jl ,:) = zt2we(:,jl,kfld+jf) 
    671                pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf) 
    672             END DO 
    673          CASE ( 1 ) 
    674             DO jl = 1, jpreci 
    675                pt2d_array(jf)%pt2d( jl ,:)= zt2we(:,jl,kfld+jf) 
    676             END DO 
    677          END SELECT 
    678       END DO 
    679        
    680       ! 3. North and south directions 
    681       ! ----------------------------- 
    682       ! always closed : we play only with the neigbours 
    683       ! 
    684       !First Array 
    685       DO jf = 1 , kfld 
    686          IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    687             ijhom = nlcj-nrecj 
    688             DO jl = 1, jprecj 
    689                zt2sn(:,jl,jf) = pt2d_array(jf)%pt2d(:, ijhom +jl ) 
    690                zt2ns(:,jl,jf) = pt2d_array(jf)%pt2d(:, jprecj+jl ) 
    691             END DO 
    692          ENDIF 
    693       END DO 
    694       ! 
    695       !                           ! Migrations 
    696       imigr = jprecj * jpi 
    697       ! 
    698       SELECT CASE ( nbondj ) 
    699       CASE ( -1 ) 
    700          CALL mppsend( 4, zt2sn(1,1,     1), kfld*imigr, nono, ml_req1 ) 
    701          CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono ) 
    702          IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    703       CASE ( 0 ) 
    704          CALL mppsend( 3, zt2ns(1,1,     1), kfld*imigr, noso, ml_req1 ) 
    705          CALL mppsend( 4, zt2sn(1,1,     1), kfld*imigr, nono, ml_req2 ) 
    706          CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono ) 
    707          CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso ) 
    708          IF(l_isend)   CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    709          IF(l_isend)   CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    710       CASE ( 1 ) 
    711          CALL mppsend( 3, zt2ns(1,1,     1), kfld*imigr, noso, ml_req1 ) 
    712          CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso ) 
    713          IF(l_isend)   CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    714       END SELECT 
    715       ! 
    716       !                           ! Write Dirichlet lateral conditions 
    717       ijhom = nlcj - jprecj 
    718       ! 
    719       DO jf = 1 , kfld 
    720          SELECT CASE ( nbondj ) 
    721          CASE ( -1 ) 
    722             DO jl = 1, jprecj 
    723                pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf ) 
    724             END DO 
    725          CASE ( 0 ) 
    726             DO jl = 1, jprecj 
    727                pt2d_array(jf)%pt2d(:,       jl ) = zt2sn(:,jl, kfld+jf ) 
    728                pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf ) 
    729             END DO 
    730          CASE ( 1 ) 
    731             DO jl = 1, jprecj 
    732                pt2d_array(jf)%pt2d(:,       jl ) = zt2sn(:,jl, kfld+jf ) 
    733             END DO 
    734          END SELECT 
    735       END DO 
    736        
    737       ! 4. north fold treatment 
    738       ! ----------------------- 
    739       ! 
    740       IF( npolj /= 0 .AND. .NOT.PRESENT(cd_mpp) ) THEN 
    741          ! 
    742          SELECT CASE ( jpni ) 
    743          CASE ( 1 )   
    744             DO jf = 1, kfld   
    745                CALL lbc_nfd( pt2d_array(jf)%pt2d(:,:), type_array(jf), psgn_array(jf) )  ! only 1 northern proc, no mpp 
    746             END DO 
    747          CASE DEFAULT    
    748             CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, kfld )   ! for all northern procs. 
    749          END SELECT 
    750          ! 
    751       ENDIF 
    752       ! 
    753       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    754       ! 
    755    END SUBROUTINE mpp_lnk_2d_multiple 
    756  
    757     
    758    SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, kfld ) 
    759       !!--------------------------------------------------------------------- 
    760       REAL(wp)        , DIMENSION(:,:), TARGET, INTENT(inout) ::   pt2d         ! 2D array on which the boundary condition is applied 
    761       CHARACTER(len=1)                        , INTENT(in   ) ::   cd_type      ! nature of pt2d array grid-points 
    762       REAL(wp)                                , INTENT(in   ) ::   psgn         ! sign used across the north fold boundary 
    763       TYPE(arrayptr)  , DIMENSION(:)          , INTENT(inout) ::   pt2d_array   !  
    764       CHARACTER(len=1), DIMENSION(:)          , INTENT(inout) ::   type_array   ! nature of pt2d_array array grid-points 
    765       REAL(wp)        , DIMENSION(:)          , INTENT(inout) ::   psgn_array   ! sign used across the north fold boundary 
    766       INTEGER                                 , INTENT(inout) ::   kfld         ! 
    767       !!--------------------------------------------------------------------- 
    768       ! 
    769       kfld                  =  kfld + 1 
    770       pt2d_array(kfld)%pt2d => pt2d 
    771       type_array(kfld)      =  cd_type 
    772       psgn_array(kfld)      =  psgn 
    773       ! 
    774    END SUBROUTINE load_array 
     336   !!---------------------------------------------------------------------- 
     337   !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
     338   !! 
     339   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     340   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     341   !!                cd_nat :   nature of array grid-points 
     342   !!                psgn   :   sign used across the north fold boundary 
     343   !!                kfld   :   optional, number of pt3d arrays 
     344   !!                cd_mpp :   optional, fill the overlap area only 
     345   !!                pval   :   optional, background value (used at closed boundaries) 
     346   !!---------------------------------------------------------------------- 
     347   ! 
     348   !                       !==  2D array and array of 2D pointer  ==! 
     349   ! 
     350#  define DIM_2d 
     351#     define ROUTINE_LNK           mpp_lnk_2d 
     352#     include "mpp_lnk_generic.h90" 
     353#     undef ROUTINE_LNK 
     354#     define MULTI 
     355#     define ROUTINE_LNK           mpp_lnk_2d_ptr 
     356#     include "mpp_lnk_generic.h90" 
     357#     undef ROUTINE_LNK 
     358#     undef MULTI 
     359#  undef DIM_2d 
     360   ! 
     361   !                       !==  3D array and array of 3D pointer  ==! 
     362   ! 
     363#  define DIM_3d 
     364#     define ROUTINE_LNK           mpp_lnk_3d 
     365#     include "mpp_lnk_generic.h90" 
     366#     undef ROUTINE_LNK 
     367#     define MULTI 
     368#     define ROUTINE_LNK           mpp_lnk_3d_ptr 
     369#     include "mpp_lnk_generic.h90" 
     370#     undef ROUTINE_LNK 
     371#     undef MULTI 
     372#  undef DIM_3d 
     373   ! 
     374   !                       !==  4D array and array of 4D pointer  ==! 
     375   ! 
     376#  define DIM_4d 
     377#     define ROUTINE_LNK           mpp_lnk_4d 
     378#     include "mpp_lnk_generic.h90" 
     379#     undef ROUTINE_LNK 
     380#     define MULTI 
     381#     define ROUTINE_LNK           mpp_lnk_4d_ptr 
     382#     include "mpp_lnk_generic.h90" 
     383#     undef ROUTINE_LNK 
     384#     undef MULTI 
     385#  undef DIM_4d 
     386 
     387   !!---------------------------------------------------------------------- 
     388   !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
     389   !! 
     390   !!   * Argument : dummy argument use in mpp_nfd_... routines 
     391   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     392   !!                cd_nat :   nature of array grid-points 
     393   !!                psgn   :   sign used across the north fold boundary 
     394   !!                kfld   :   optional, number of pt3d arrays 
     395   !!                cd_mpp :   optional, fill the overlap area only 
     396   !!                pval   :   optional, background value (used at closed boundaries) 
     397   !!---------------------------------------------------------------------- 
     398   ! 
     399   !                       !==  2D array and array of 2D pointer  ==! 
     400   ! 
     401#  define DIM_2d 
     402#     define ROUTINE_NFD           mpp_nfd_2d 
     403#     include "mpp_nfd_generic.h90" 
     404#     undef ROUTINE_NFD 
     405#     define MULTI 
     406#     define ROUTINE_NFD           mpp_nfd_2d_ptr 
     407#     include "mpp_nfd_generic.h90" 
     408#     undef ROUTINE_NFD 
     409#     undef MULTI 
     410#  undef DIM_2d 
     411   ! 
     412   !                       !==  3D array and array of 3D pointer  ==! 
     413   ! 
     414#  define DIM_3d 
     415#     define ROUTINE_NFD           mpp_nfd_3d 
     416#     include "mpp_nfd_generic.h90" 
     417#     undef ROUTINE_NFD 
     418#     define MULTI 
     419#     define ROUTINE_NFD           mpp_nfd_3d_ptr 
     420#     include "mpp_nfd_generic.h90" 
     421#     undef ROUTINE_NFD 
     422#     undef MULTI 
     423#  undef DIM_3d 
     424   ! 
     425   !                       !==  4D array and array of 4D pointer  ==! 
     426   ! 
     427#  define DIM_4d 
     428#     define ROUTINE_NFD           mpp_nfd_4d 
     429#     include "mpp_nfd_generic.h90" 
     430#     undef ROUTINE_NFD 
     431#     define MULTI 
     432#     define ROUTINE_NFD           mpp_nfd_4d_ptr 
     433#     include "mpp_nfd_generic.h90" 
     434#     undef ROUTINE_NFD 
     435#     undef MULTI 
     436#  undef DIM_4d 
     437 
     438 
     439   !!---------------------------------------------------------------------- 
     440   !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  *** 
     441   !! 
     442   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     443   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
     444   !!                cd_nat :   nature of array grid-points 
     445   !!                psgn   :   sign used across the north fold boundary 
     446   !!                kb_bdy :   BDY boundary set 
     447   !!                kfld   :   optional, number of pt3d arrays 
     448   !!---------------------------------------------------------------------- 
     449   ! 
     450   !                       !==  2D array and array of 2D pointer  ==! 
     451   ! 
     452#  define DIM_2d 
     453#     define ROUTINE_BDY           mpp_lnk_bdy_2d 
     454#     include "mpp_bdy_generic.h90" 
     455#     undef ROUTINE_BDY 
     456#     define MULTI 
     457#     define ROUTINE_BDY           mpp_lnk_bdy_2d_ptr 
     458#     include "mpp_bdy_generic.h90" 
     459#     undef ROUTINE_BDY 
     460#     undef MULTI 
     461#  undef DIM_2d 
     462   ! 
     463   !                       !==  3D array and array of 3D pointer  ==! 
     464   ! 
     465#  define DIM_3d 
     466#     define ROUTINE_BDY           mpp_lnk_bdy_3d 
     467#     include "mpp_bdy_generic.h90" 
     468#     undef ROUTINE_BDY 
     469#     define MULTI 
     470#     define ROUTINE_BDY           mpp_lnk_bdy_3d_ptr 
     471#     include "mpp_bdy_generic.h90" 
     472#     undef ROUTINE_BDY 
     473#     undef MULTI 
     474#  undef DIM_3d 
     475   ! 
     476   !                       !==  4D array and array of 4D pointer  ==! 
     477   ! 
     478!!#  define DIM_4d 
     479!!#     define ROUTINE_BDY           mpp_lnk_bdy_4d 
     480!!#     include "mpp_bdy_generic.h90" 
     481!!#     undef ROUTINE_BDY 
     482!!#     define MULTI 
     483!!#     define ROUTINE_BDY           mpp_lnk_bdy_4d_ptr 
     484!!#     include "mpp_bdy_generic.h90" 
     485!!#     undef ROUTINE_BDY 
     486!!#     undef MULTI 
     487!!#  undef DIM_4d 
     488 
     489   !!---------------------------------------------------------------------- 
     490   !! 
     491   !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D 
    775492    
    776493    
    777    SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
    778       &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
    779       &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
    780       !!--------------------------------------------------------------------- 
    781       REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA    ! 2D arrays on which the lbc is applied 
    782       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
    783       REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI  
    784       CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA ! nature of pt2D. array grid-points 
    785       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
    786       CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
    787       REAL(wp)                                      , INTENT(in   ) ::   psgnA    ! sign used across the north fold 
    788       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
    789       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI    
    790       CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    791       REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    792       !! 
    793       INTEGER :: kfld 
    794       TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array  
    795       CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of pt2d array grid-points 
    796       REAL(wp)         , DIMENSION(9) ::   psgn_array    ! sign used across the north fold boundary 
    797       !!--------------------------------------------------------------------- 
    798       ! 
    799       kfld = 0 
    800       ! 
    801       !                 ! Load the first array 
    802       CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, kfld ) 
    803       ! 
    804       !                 ! Look if more arrays are added 
    805       IF( PRESENT(psgnB) )   CALL load_array( pt2dB, cd_typeB, psgnB, pt2d_array, type_array, psgn_array, kfld ) 
    806       IF( PRESENT(psgnC) )   CALL load_array( pt2dC, cd_typeC, psgnC, pt2d_array, type_array, psgn_array, kfld ) 
    807       IF( PRESENT(psgnD) )   CALL load_array( pt2dD, cd_typeD, psgnD, pt2d_array, type_array, psgn_array, kfld ) 
    808       IF( PRESENT(psgnE) )   CALL load_array( pt2dE, cd_typeE, psgnE, pt2d_array, type_array, psgn_array, kfld ) 
    809       IF( PRESENT(psgnF) )   CALL load_array( pt2dF, cd_typeF, psgnF, pt2d_array, type_array, psgn_array, kfld ) 
    810       IF( PRESENT(psgnG) )   CALL load_array( pt2dG, cd_typeG, psgnG, pt2d_array, type_array, psgn_array, kfld ) 
    811       IF( PRESENT(psgnH) )   CALL load_array( pt2dH, cd_typeH, psgnH, pt2d_array, type_array, psgn_array, kfld ) 
    812       IF( PRESENT(psgnI) )   CALL load_array( pt2dI, cd_typeI, psgnI, pt2d_array, type_array, psgn_array, kfld ) 
    813       ! 
    814       CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp,pval ) 
    815       ! 
    816    END SUBROUTINE mpp_lnk_2d_9 
    817  
    818  
    819    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    820       !!---------------------------------------------------------------------- 
    821       !!                  ***  routine mpp_lnk_2d  *** 
    822       !! 
    823       !! ** Purpose :   Message passing manadgement for 2d array 
    824       !! 
    825       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    826       !!      between processors following neighboring subdomains. 
    827       !!            domain parameters 
    828       !!                    nlci   : first dimension of the local subdomain 
    829       !!                    nlcj   : second dimension of the local subdomain 
    830       !!                    nbondi : mark for "east-west local boundary" 
    831       !!                    nbondj : mark for "north-south local boundary" 
    832       !!                    noea   : number for local neighboring processors 
    833       !!                    nowe   : number for local neighboring processors 
    834       !!                    noso   : number for local neighboring processors 
    835       !!                    nono   : number for local neighboring processors 
    836       !! 
    837       !!---------------------------------------------------------------------- 
    838       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
    839       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! nature of pt2d array grid-points 
    840       REAL(wp)                    , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    841       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    842       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    843       !! 
    844       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    845       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    846       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    847       REAL(wp) ::   zland 
    848       INTEGER, DIMENSION(MPI_STATUS_SIZE)     ::   ml_stat       ! for key_mpi_isend 
    849       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    850       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    851       !!---------------------------------------------------------------------- 
    852       ! 
    853       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    854          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    855       ! 
    856       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    857       ELSE                         ;   zland = 0._wp     ! zero by default 
    858       ENDIF 
    859  
    860       ! 1. standard boundary treatment 
    861       ! ------------------------------ 
    862       ! 
    863       IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    864          ! 
    865          ! WARNING pt2d is defined only between nld and nle 
    866          DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    867             pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej) 
    868             pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej) 
    869             pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej) 
    870          END DO 
    871          DO ji = nlci+1, jpi                 ! added column(s) (full) 
    872             pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej) 
    873             pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     ) 
    874             pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej) 
    875          END DO 
    876          ! 
    877       ELSE                              ! standard close or cyclic treatment 
    878          ! 
    879          !                                   ! East-West boundaries 
    880          IF( nbondi == 2 .AND.   &                !* cyclic 
    881             &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    882             pt2d( 1 ,:) = pt2d(jpim1,:)                                          ! west 
    883             pt2d(jpi,:) = pt2d(  2  ,:)                                          ! east 
    884          ELSE                                     !* closed 
    885             IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point 
    886                                          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    887          ENDIF 
    888          !                                   ! North-South boundaries 
    889          !                                        !* cyclic 
    890          IF( nbondj == 2 .AND. jperio == 7 ) THEN 
    891             pt2d(:,  1 ) = pt2d(:,jpjm1) 
    892             pt2d(:, jpj) = pt2d(:,    2) 
    893          ELSE                                     !* closed 
    894             IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point 
    895                                          pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    896          ENDIF 
    897       ENDIF 
    898  
    899       ! 2. East and west directions exchange 
    900       ! ------------------------------------ 
    901       ! we play with the neigbours AND the row number because of the periodicity 
    902       ! 
    903       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    904       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    905          iihom = nlci-nreci 
    906          DO jl = 1, jpreci 
    907             zt2ew(:,jl,1) = pt2d(jpreci+jl,:) 
    908             zt2we(:,jl,1) = pt2d(iihom +jl,:) 
    909          END DO 
    910       END SELECT 
    911       ! 
    912       !                           ! Migrations 
    913       imigr = jpreci * jpj 
    914       ! 
    915       SELECT CASE ( nbondi ) 
    916       CASE ( -1 ) 
    917          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    918          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    919          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    920       CASE ( 0 ) 
    921          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    922          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    923          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    924          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    925          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    926          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    927       CASE ( 1 ) 
    928          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    929          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    930          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    931       END SELECT 
    932       ! 
    933       !                           ! Write Dirichlet lateral conditions 
    934       iihom = nlci - jpreci 
    935       ! 
    936       SELECT CASE ( nbondi ) 
    937       CASE ( -1 ) 
    938          DO jl = 1, jpreci 
    939             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
    940          END DO 
    941       CASE ( 0 ) 
    942          DO jl = 1, jpreci 
    943             pt2d(jl      ,:) = zt2we(:,jl,2) 
    944             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
    945          END DO 
    946       CASE ( 1 ) 
    947          DO jl = 1, jpreci 
    948             pt2d(jl      ,:) = zt2we(:,jl,2) 
    949          END DO 
    950       END SELECT 
    951  
    952       ! 3. North and south directions 
    953       ! ----------------------------- 
    954       ! always closed : we play only with the neigbours 
    955       ! 
    956       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    957          ijhom = nlcj-nrecj 
    958          DO jl = 1, jprecj 
    959             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) 
    960             zt2ns(:,jl,1) = pt2d(:,jprecj+jl) 
    961          END DO 
    962       ENDIF 
    963       ! 
    964       !                           ! Migrations 
    965       imigr = jprecj * jpi 
    966       ! 
    967       SELECT CASE ( nbondj ) 
    968       CASE ( -1 ) 
    969          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    970          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    971          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    972       CASE ( 0 ) 
    973          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    974          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    975          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    976          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    977          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    978          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    979       CASE ( 1 ) 
    980          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    981          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    982          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    983       END SELECT 
    984       ! 
    985       !                           ! Write Dirichlet lateral conditions 
    986       ijhom = nlcj - jprecj 
    987       ! 
    988       SELECT CASE ( nbondj ) 
    989       CASE ( -1 ) 
    990          DO jl = 1, jprecj 
    991             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
    992          END DO 
    993       CASE ( 0 ) 
    994          DO jl = 1, jprecj 
    995             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    996             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
    997          END DO 
    998       CASE ( 1 ) 
    999          DO jl = 1, jprecj 
    1000             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    1001          END DO 
    1002       END SELECT 
    1003  
    1004       ! 4. north fold treatment 
    1005       ! ----------------------- 
    1006       ! 
    1007       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1008          ! 
    1009          SELECT CASE ( jpni ) 
    1010          CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1011          CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    1012          END SELECT 
    1013          ! 
    1014       ENDIF 
    1015       ! 
    1016       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    1017       ! 
    1018    END SUBROUTINE mpp_lnk_2d 
    1019  
    1020  
    1021    SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 
    1022       !!---------------------------------------------------------------------- 
    1023       !!                  ***  routine mpp_lnk_3d_gather  *** 
    1024       !! 
    1025       !! ** Purpose :   Message passing manadgement for two 3D arrays 
    1026       !! 
    1027       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1028       !!      between processors following neighboring subdomains. 
    1029       !!            domain parameters 
    1030       !!                    nlci   : first dimension of the local subdomain 
    1031       !!                    nlcj   : second dimension of the local subdomain 
    1032       !!                    nbondi : mark for "east-west local boundary" 
    1033       !!                    nbondj : mark for "north-south local boundary" 
    1034       !!                    noea   : number for local neighboring processors 
    1035       !!                    nowe   : number for local neighboring processors 
    1036       !!                    noso   : number for local neighboring processors 
    1037       !!                    nono   : number for local neighboring processors 
    1038       !! 
    1039       !! ** Action  :   ptab1 and ptab2  with update value at its periphery 
    1040       !! 
    1041       !!---------------------------------------------------------------------- 
    1042       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab1     ! 1st 3D array on which the boundary condition is applied 
    1043       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type1  ! nature of ptab1 arrays 
    1044       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab2     ! 3nd 3D array on which the boundary condition is applied 
    1045       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type2  ! nature of ptab2 arrays 
    1046       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across the north fold boundary 
    1047       ! 
    1048       INTEGER  ::   jl                         ! dummy loop indices 
    1049       INTEGER  ::   ipk                        ! 3rd dimension of the input array 
    1050       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1051       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1052       INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   ml_stat   ! for key_mpi_isend 
    1053       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ns, zt4sn   ! 2 x 3d for north-south & south-north 
    1054       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ew, zt4we   ! 2 x 3d for east-west & west-east 
    1055       !!---------------------------------------------------------------------- 
    1056       ! 
    1057       ipk = SIZE( ptab1, 3 ) 
    1058       ! 
    1059       ALLOCATE( zt4ns(jpi,jprecj,ipk,2,2), zt4sn(jpi,jprecj,ipk,2,2) ,    & 
    1060          &      zt4ew(jpj,jpreci,ipk,2,2), zt4we(jpj,jpreci,ipk,2,2) ) 
    1061  
    1062       ! 1. standard boundary treatment 
    1063       ! ------------------------------ 
    1064       !                                      ! East-West boundaries 
    1065       !                                           !* Cyclic  
    1066       IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    1067          ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 
    1068          ptab1(jpi,:,:) = ptab1(  2  ,:,:) 
    1069          ptab2( 1 ,:,:) = ptab2(jpim1,:,:) 
    1070          ptab2(jpi,:,:) = ptab2(  2  ,:,:) 
    1071       ELSE                                        !* closed 
    1072          IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0._wp   ! south except at F-point 
    1073          IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0._wp 
    1074                                        ptab1(nlci-jpreci+1:jpi   ,:,:) = 0._wp   ! north 
    1075                                        ptab2(nlci-jpreci+1:jpi   ,:,:) = 0._wp 
    1076       ENDIF 
    1077       !                                     ! North-South boundaries 
    1078       !                                           !* cyclic 
    1079       IF( nbondj == 2 .AND. jperio == 7 ) THEN 
    1080          ptab1(:,  1  ,:) = ptab1(:, jpjm1 , :) 
    1081          ptab1(:, jpj ,:) = ptab1(:,   2   , :) 
    1082          ptab2(:,  1  ,:) = ptab2(:, jpjm1 , :) 
    1083          ptab2(:, jpj ,:) = ptab2(:,   2   , :) 
    1084       ELSE      
    1085          !                                        !* closed 
    1086          IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0._wp   ! south except at F-point 
    1087          IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0._wp 
    1088                                        ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0._wp   ! north 
    1089                                        ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0._wp 
    1090       ENDIF 
    1091  
    1092       ! 2. East and west directions exchange 
    1093       ! ------------------------------------ 
    1094       ! we play with the neigbours AND the row number because of the periodicity 
    1095       ! 
    1096       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1097       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1098          iihom = nlci-nreci 
    1099          DO jl = 1, jpreci 
    1100             zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 
    1101             zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 
    1102             zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 
    1103             zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 
    1104          END DO 
    1105       END SELECT 
    1106       ! 
    1107       !                           ! Migrations 
    1108       imigr = jpreci * jpj * ipk *2 
    1109       ! 
    1110       SELECT CASE ( nbondi ) 
    1111       CASE ( -1 ) 
    1112          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
    1113          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    1114          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1115       CASE ( 0 ) 
    1116          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    1117          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 ) 
    1118          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    1119          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
    1120          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1121          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1122       CASE ( 1 ) 
    1123          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    1124          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
    1125          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1126       END SELECT 
    1127       ! 
    1128       !                           ! Write Dirichlet lateral conditions 
    1129       iihom = nlci - jpreci 
    1130       ! 
    1131       SELECT CASE ( nbondi ) 
    1132       CASE ( -1 ) 
    1133          DO jl = 1, jpreci 
    1134             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    1135             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
    1136          END DO 
    1137       CASE ( 0 ) 
    1138          DO jl = 1, jpreci 
    1139             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    1140             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    1141             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    1142             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
    1143          END DO 
    1144       CASE ( 1 ) 
    1145          DO jl = 1, jpreci 
    1146             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    1147             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    1148          END DO 
    1149       END SELECT 
    1150  
    1151       ! 3. North and south directions 
    1152       ! ----------------------------- 
    1153       ! always closed : we play only with the neigbours 
    1154       ! 
    1155       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1156          ijhom = nlcj - nrecj 
    1157          DO jl = 1, jprecj 
    1158             zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 
    1159             zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 
    1160             zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 
    1161             zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 
    1162          END DO 
    1163       ENDIF 
    1164       ! 
    1165       !                           ! Migrations 
    1166       imigr = jprecj * jpi * ipk * 2 
    1167       ! 
    1168       SELECT CASE ( nbondj ) 
    1169       CASE ( -1 ) 
    1170          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
    1171          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    1172          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1173       CASE ( 0 ) 
    1174          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    1175          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 
    1176          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    1177          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
    1178          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1179          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1180       CASE ( 1 ) 
    1181          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    1182          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
    1183          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1184       END SELECT 
    1185       ! 
    1186       !                           ! Write Dirichlet lateral conditions 
    1187       ijhom = nlcj - jprecj 
    1188       ! 
    1189       SELECT CASE ( nbondj ) 
    1190       CASE ( -1 ) 
    1191          DO jl = 1, jprecj 
    1192             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    1193             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
    1194          END DO 
    1195       CASE ( 0 ) 
    1196          DO jl = 1, jprecj 
    1197             ptab1(:,jl      ,:) = zt4sn(:,jl,:,1,2) 
    1198             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    1199             ptab2(:,jl      ,:) = zt4sn(:,jl,:,2,2) 
    1200             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
    1201          END DO 
    1202       CASE ( 1 ) 
    1203          DO jl = 1, jprecj 
    1204             ptab1(:,jl,:) = zt4sn(:,jl,:,1,2) 
    1205             ptab2(:,jl,:) = zt4sn(:,jl,:,2,2) 
    1206          END DO 
    1207       END SELECT 
    1208  
    1209       ! 4. north fold treatment 
    1210       ! ----------------------- 
    1211       IF( npolj /= 0 ) THEN 
    1212          ! 
    1213          SELECT CASE ( jpni ) 
    1214          CASE ( 1 ) 
    1215             CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs. 
    1216             CALL lbc_nfd      ( ptab2, cd_type2, psgn ) 
    1217          CASE DEFAULT 
    1218             CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs. 
    1219             CALL mpp_lbc_north (ptab2, cd_type2, psgn) 
    1220          END SELECT 
    1221          ! 
    1222       ENDIF 
    1223       ! 
    1224       DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we ) 
    1225       ! 
    1226    END SUBROUTINE mpp_lnk_3d_gather 
     494   !!    mpp_lnk_2d_e     utilisé dans ICB  
     495 
     496 
     497   !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
     498    
     499    
     500   !!---------------------------------------------------------------------- 
    1227501 
    1228502 
    … …  
    1297571         ! 
    1298572         SELECT CASE ( jpni ) 
    1299          CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    1300          CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                  , cd_type, psgn             ) 
     573!!gm ERROR        CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
     574!!gm ERROR         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                  , cd_type, psgn             ) 
    1301575         END SELECT 
    1302576         ! 
    … …  
    1411685 
    1412686 
    1413    SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    1414       !!---------------------------------------------------------------------- 
    1415       !!                  ***  routine mpp_lnk_sum_3d  *** 
    1416       !! 
    1417       !! ** Purpose :   Message passing manadgement (sum the overlap region) 
    1418       !! 
    1419       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1420       !!      between processors following neighboring subdomains. 
    1421       !!            domain parameters 
    1422       !!                    nlci   : first dimension of the local subdomain 
    1423       !!                    nlcj   : second dimension of the local subdomain 
    1424       !!                    nbondi : mark for "east-west local boundary" 
    1425       !!                    nbondj : mark for "north-south local boundary" 
    1426       !!                    noea   : number for local neighboring processors 
    1427       !!                    nowe   : number for local neighboring processors 
    1428       !!                    noso   : number for local neighboring processors 
    1429       !!                    nono   : number for local neighboring processors 
    1430       !! 
    1431       !! ** Action  :   ptab with update value at its periphery 
    1432       !! 
    1433       !!---------------------------------------------------------------------- 
    1434       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    1435       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  !  nature of ptab array grid-points 
    1436       REAL(wp)                        , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    1437       CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    1438       REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1439       ! 
    1440       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    1441       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1442       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1443       REAL(wp) ::   zland 
    1444       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1445       ! 
    1446       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    1447       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    1448       !!---------------------------------------------------------------------- 
    1449       ! 
    1450       ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
    1451          &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
    1452       ! 
    1453       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1454       ELSE                         ;   zland = 0._wp     ! zero by default 
    1455       ENDIF 
    1456  
    1457       ! 1. standard boundary treatment 
    1458       ! ------------------------------ 
    1459       ! 2. East and west directions exchange 
    1460       ! ------------------------------------ 
    1461       ! we play with the neigbours AND the row number because of the periodicity 
    1462       ! 
    1463       SELECT CASE ( nbondi )      ! Read lateral conditions 
    1464       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1465       iihom = nlci-jpreci 
    1466          DO jl = 1, jpreci 
    1467             zt3ew(:,jl,:,1) = ptab(jl      ,:,:) ; ptab(jl      ,:,:) = 0._wp 
    1468             zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0._wp  
    1469          END DO 
    1470       END SELECT 
    1471       ! 
    1472       !                           ! Migrations 
    1473       imigr = jpreci * jpj * jpk 
    1474       ! 
    1475       SELECT CASE ( nbondi ) 
    1476       CASE ( -1 ) 
    1477          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    1478          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    1479          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1480       CASE ( 0 ) 
    1481          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    1482          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    1483          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    1484          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    1485          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1486          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1487       CASE ( 1 ) 
    1488          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    1489          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    1490          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1491       END SELECT 
    1492       ! 
    1493       !                           ! Write lateral conditions 
    1494       iihom = nlci-nreci 
    1495       ! 
    1496       SELECT CASE ( nbondi ) 
    1497       CASE ( -1 ) 
    1498          DO jl = 1, jpreci 
    1499             ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 
    1500          END DO 
    1501       CASE ( 0 ) 
    1502          DO jl = 1, jpreci 
    1503             ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
    1504             ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 
    1505          END DO 
    1506       CASE ( 1 ) 
    1507          DO jl = 1, jpreci 
    1508             ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
    1509          END DO 
    1510       END SELECT 
    1511  
    1512       ! 3. North and south directions 
    1513       ! ----------------------------- 
    1514       ! always closed : we play only with the neigbours 
    1515       ! 
    1516       IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
    1517          ijhom = nlcj-jprecj 
    1518          DO jl = 1, jprecj 
    1519             zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:)   ;   ptab(:,ijhom+jl,:) = 0._wp 
    1520             zt3ns(:,jl,:,1) = ptab(:,jl      ,:)   ;   ptab(:,jl      ,:) = 0._wp 
    1521          END DO 
    1522       ENDIF 
    1523       ! 
    1524       !                           ! Migrations 
    1525       imigr = jprecj * jpi * jpk 
    1526       ! 
    1527       SELECT CASE ( nbondj ) 
    1528       CASE ( -1 ) 
    1529          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    1530          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    1531          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1532       CASE ( 0 ) 
    1533          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    1534          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    1535          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    1536          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    1537          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1538          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    1539       CASE ( 1 ) 
    1540          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    1541          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    1542          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    1543       END SELECT 
    1544       ! 
    1545       !                           ! Write lateral conditions 
    1546       ijhom = nlcj-nrecj 
    1547       ! 
    1548       SELECT CASE ( nbondj ) 
    1549       CASE ( -1 ) 
    1550          DO jl = 1, jprecj 
    1551             ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) 
    1552          END DO 
    1553       CASE ( 0 ) 
    1554          DO jl = 1, jprecj 
    1555             ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) 
    1556             ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) 
    1557          END DO 
    1558       CASE ( 1 ) 
    1559          DO jl = 1, jprecj 
    1560             ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl   ,:,2) 
    1561          END DO 
    1562       END SELECT 
    1563  
    1564       ! 4. north fold treatment 
    1565       ! ----------------------- 
    1566       ! 
    1567       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1568          ! 
    1569          SELECT CASE ( jpni ) 
    1570          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1571          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    1572          END SELECT 
    1573          ! 
    1574       ENDIF 
    1575       ! 
    1576       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
    1577       ! 
    1578    END SUBROUTINE mpp_lnk_sum_3d 
    1579  
    1580  
    1581    SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    1582       !!---------------------------------------------------------------------- 
    1583       !!                  ***  routine mpp_lnk_sum_2d  *** 
    1584       !! 
    1585       !! ** Purpose :   Message passing manadgement for 2d array (sum the overlap region) 
    1586       !! 
    1587       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1588       !!      between processors following neighboring subdomains. 
    1589       !!            domain parameters 
    1590       !!                    nlci   : first dimension of the local subdomain 
    1591       !!                    nlcj   : second dimension of the local subdomain 
    1592       !!                    nbondi : mark for "east-west local boundary" 
    1593       !!                    nbondj : mark for "north-south local boundary" 
    1594       !!                    noea   : number for local neighboring processors 
    1595       !!                    nowe   : number for local neighboring processors 
    1596       !!                    noso   : number for local neighboring processors 
    1597       !!                    nono   : number for local neighboring processors 
    1598       !!---------------------------------------------------------------------- 
    1599       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
    1600       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! nature of pt2d array grid-points 
    1601       REAL(wp)                    , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    1602       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
    1603       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
    1604       !! 
    1605       INTEGER  ::   ji, jj, jl   ! dummy loop indices 
    1606       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    1607       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1608       REAL(wp) ::   zland 
    1609       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1610       ! 
    1611       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    1612       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    1613       !!---------------------------------------------------------------------- 
    1614       ! 
    1615       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    1616          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    1617       ! 
    1618       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    1619       ELSE                         ;   zland = 0._wp     ! zero by default 
    1620       ENDIF 
    1621  
    1622       ! 1. standard boundary treatment 
    1623       ! ------------------------------ 
    1624       ! 2. East and west directions exchange 
    1625       ! ------------------------------------ 
    1626       ! we play with the neigbours AND the row number because of the periodicity 
    1627       ! 
    1628       SELECT CASE ( nbondi )      ! Read lateral conditions 
    1629       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1630          iihom = nlci - jpreci 
    1631          DO jl = 1, jpreci 
    1632             zt2ew(:,jl,1) = pt2d(jl       ,:) ; pt2d(jl       ,:) = 0.0_wp 
    1633             zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp 
    1634          END DO 
    1635       END SELECT 
    1636       ! 
    1637       !                           ! Migrations 
    1638       imigr = jpreci * jpj 
    1639       ! 
    1640       SELECT CASE ( nbondi ) 
    1641       CASE ( -1 ) 
    1642          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    1643          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1644          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1645       CASE ( 0 ) 
    1646          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1647          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    1648          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1649          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    1650          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1651          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1652       CASE ( 1 ) 
    1653          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1654          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    1655          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1656       END SELECT 
    1657       ! 
    1658       !                           ! Write lateral conditions 
    1659       iihom = nlci-nreci 
    1660       ! 
    1661       SELECT CASE ( nbondi ) 
    1662       CASE ( -1 ) 
    1663          DO jl = 1, jpreci 
    1664             pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) 
    1665          END DO 
    1666       CASE ( 0 ) 
    1667          DO jl = 1, jpreci 
    1668             pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
    1669             pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) 
    1670          END DO 
    1671       CASE ( 1 ) 
    1672          DO jl = 1, jpreci 
    1673             pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
    1674          END DO 
    1675       END SELECT 
    1676  
    1677  
    1678       ! 3. North and south directions 
    1679       ! ----------------------------- 
    1680       ! always closed : we play only with the neigbours 
    1681       ! 
    1682       IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
    1683          ijhom = nlcj - jprecj 
    1684          DO jl = 1, jprecj 
    1685             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp 
    1686             zt2ns(:,jl,1) = pt2d(:,jl       ) ; pt2d(:,jl       ) = 0.0_wp 
    1687          END DO 
    1688       ENDIF 
    1689       ! 
    1690       !                           ! Migrations 
    1691       imigr = jprecj * jpi 
    1692       ! 
    1693       SELECT CASE ( nbondj ) 
    1694       CASE ( -1 ) 
    1695          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    1696          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1697          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1698       CASE ( 0 ) 
    1699          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1700          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    1701          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1702          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    1703          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1704          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1705       CASE ( 1 ) 
    1706          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1707          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    1708          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1709       END SELECT 
    1710       ! 
    1711       !                           ! Write lateral conditions 
    1712       ijhom = nlcj-nrecj 
    1713       ! 
    1714       SELECT CASE ( nbondj ) 
    1715       CASE ( -1 ) 
    1716          DO jl = 1, jprecj 
    1717             pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) 
    1718          END DO 
    1719       CASE ( 0 ) 
    1720          DO jl = 1, jprecj 
    1721             pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
    1722             pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) 
    1723          END DO 
    1724       CASE ( 1 ) 
    1725          DO jl = 1, jprecj 
    1726             pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
    1727          END DO 
    1728       END SELECT 
    1729  
    1730       ! 4. north fold treatment 
    1731       ! ----------------------- 
    1732       ! 
    1733       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    1734          ! 
    1735          SELECT CASE ( jpni ) 
    1736          CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
    1737          CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
    1738          END SELECT 
    1739          ! 
    1740       ENDIF 
    1741       ! 
    1742       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    1743       ! 
    1744    END SUBROUTINE mpp_lnk_sum_2d 
    1745  
    1746  
    1747687   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) 
    1748688      !!---------------------------------------------------------------------- 
    … …  
    1845785   END SUBROUTINE mppscatter 
    1846786 
    1847  
     787   !!---------------------------------------------------------------------- 
     788   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
     789   !!    
     790   !!---------------------------------------------------------------------- 
     791   !! 
    1848792   SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 
    1849       !!---------------------------------------------------------------------- 
    1850       !!                  ***  routine mppmax_a_int  *** 
    1851       !! 
    1852       !! ** Purpose :   Find maximum value in an integer layout array 
    1853       !! 
    1854793      !!---------------------------------------------------------------------- 
    1855794      INTEGER , INTENT(in   )                  ::   kdim   ! size of array 
    1856795      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array 
    1857796      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   ! 
    1858       ! 
    1859       INTEGER :: ierror, localcomm   ! temporary integer 
     797      INTEGER :: ierror, ilocalcomm   ! temporary integer 
    1860798      INTEGER, DIMENSION(kdim) ::   iwork 
    1861799      !!---------------------------------------------------------------------- 
    1862       ! 
    1863       localcomm = mpi_comm_opa 
    1864       IF( PRESENT(kcom) )   localcomm = kcom 
    1865       ! 
    1866       CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror ) 
    1867       ! 
     800      ilocalcomm = mpi_comm_opa 
     801      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     802      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror ) 
    1868803      ktab(:) = iwork(:) 
    1869       ! 
    1870804   END SUBROUTINE mppmax_a_int 
    1871  
    1872  
     805   !! 
    1873806   SUBROUTINE mppmax_int( ktab, kcom ) 
    1874       !!---------------------------------------------------------------------- 
    1875       !!                  ***  routine mppmax_int  *** 
    1876       !! 
    1877       !! ** Purpose :   Find maximum value in an integer layout array 
    1878       !! 
    1879807      !!---------------------------------------------------------------------- 
    1880808      INTEGER, INTENT(inout)           ::   ktab   ! ??? 
    1881809      INTEGER, INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
    1882       ! 
    1883       INTEGER ::   ierror, iwork, localcomm   ! temporary integer 
    1884       !!---------------------------------------------------------------------- 
    1885       ! 
    1886       localcomm = mpi_comm_opa 
    1887       IF( PRESENT(kcom) )   localcomm = kcom 
    1888       ! 
    1889       CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 
    1890       ! 
     810      INTEGER ::   ierror, iwork, ilocalcomm   ! temporary integer 
     811      !!---------------------------------------------------------------------- 
     812      ilocalcomm = mpi_comm_opa 
     813      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     814      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, ilocalcomm, ierror ) 
    1891815      ktab = iwork 
    1892       ! 
    1893816   END SUBROUTINE mppmax_int 
    1894  
    1895  
     817   !! 
     818   SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 
     819      !!---------------------------------------------------------------------- 
     820      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab 
     821      INTEGER                  , INTENT(in   ) ::   kdim 
     822      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom 
     823      INTEGER :: ierror, ilocalcomm 
     824      REAL(wp), DIMENSION(kdim) ::  zwork 
     825      !!---------------------------------------------------------------------- 
     826      ilocalcomm = mpi_comm_opa 
     827      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     828      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
     829      ptab(:) = zwork(:) 
     830   END SUBROUTINE mppmax_a_real 
     831   !! 
     832   SUBROUTINE mppmax_real( ptab, kcom ) 
     833      !!---------------------------------------------------------------------- 
     834      REAL(wp), INTENT(inout)           ::   ptab   ! ??? 
     835      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     836      INTEGER  ::   ierror, ilocalcomm 
     837      REAL(wp) ::   zwork 
     838      !!---------------------------------------------------------------------- 
     839      ilocalcomm = mpi_comm_opa 
     840      IF( PRESENT(kcom) )   ilocalcomm = kcom! 
     841      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
     842      ptab = zwork 
     843   END SUBROUTINE mppmax_real 
     844 
     845 
     846   !!---------------------------------------------------------------------- 
     847   !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  *** 
     848   !!    
     849   !!---------------------------------------------------------------------- 
     850   !! 
    1896851   SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 
    1897       !!---------------------------------------------------------------------- 
    1898       !!                  ***  routine mppmin_a_int  *** 
    1899       !! 
    1900       !! ** Purpose :   Find minimum value in an integer layout array 
    1901       !! 
    1902852      !!---------------------------------------------------------------------- 
    1903853      INTEGER , INTENT( in  )                  ::   kdim   ! size of array 
    … …  
    1905855      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom   ! input array 
    1906856      !! 
    1907       INTEGER ::   ierror, localcomm   ! temporary integer 
     857      INTEGER ::   ierror, ilocalcomm   ! temporary integer 
    1908858      INTEGER, DIMENSION(kdim) ::   iwork 
    1909859      !!---------------------------------------------------------------------- 
    1910       ! 
    1911       localcomm = mpi_comm_opa 
    1912       IF( PRESENT(kcom) )   localcomm = kcom 
    1913       ! 
    1914       CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror ) 
    1915       ! 
     860      ilocalcomm = mpi_comm_opa 
     861      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     862      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror ) 
    1916863      ktab(:) = iwork(:) 
    1917       ! 
    1918864   END SUBROUTINE mppmin_a_int 
    1919  
    1920  
     865   !! 
    1921866   SUBROUTINE mppmin_int( ktab, kcom ) 
    1922       !!---------------------------------------------------------------------- 
    1923       !!                  ***  routine mppmin_int  *** 
    1924       !! 
    1925       !! ** Purpose :   Find minimum value in an integer layout array 
    1926       !! 
    1927867      !!---------------------------------------------------------------------- 
    1928868      INTEGER, INTENT(inout) ::   ktab      ! ??? 
    1929869      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array 
    1930870      !! 
    1931       INTEGER ::  ierror, iwork, localcomm 
    1932       !!---------------------------------------------------------------------- 
    1933       ! 
    1934       localcomm = mpi_comm_opa 
    1935       IF( PRESENT(kcom) )   localcomm = kcom 
    1936       ! 
    1937       CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 
    1938       ! 
     871      INTEGER ::  ierror, iwork, ilocalcomm 
     872      !!---------------------------------------------------------------------- 
     873      ilocalcomm = mpi_comm_opa 
     874      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     875      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, ilocalcomm, ierror ) 
    1939876      ktab = iwork 
    1940       ! 
    1941877   END SUBROUTINE mppmin_int 
    1942  
    1943  
     878   !! 
     879   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
     880      !!---------------------------------------------------------------------- 
     881      INTEGER , INTENT(in   )                  ::   kdim 
     882      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
     883      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom 
     884      INTEGER :: ierror, ilocalcomm 
     885      REAL(wp), DIMENSION(kdim) ::   zwork 
     886      !!----------------------------------------------------------------------- 
     887      ilocalcomm = mpi_comm_opa 
     888      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     889      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 
     890      ptab(:) = zwork(:) 
     891   END SUBROUTINE mppmin_a_real 
     892   !! 
     893   SUBROUTINE mppmin_real( ptab, kcom ) 
     894      !!----------------------------------------------------------------------- 
     895      REAL(wp), INTENT(inout)           ::   ptab        ! 
     896      INTEGER , INTENT(in   ), OPTIONAL :: kcom 
     897      INTEGER  ::   ierror, ilocalcomm 
     898      REAL(wp) ::   zwork 
     899      !!----------------------------------------------------------------------- 
     900      ilocalcomm = mpi_comm_opa 
     901      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     902      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 
     903      ptab = zwork 
     904   END SUBROUTINE mppmin_real 
     905 
     906 
     907   !!---------------------------------------------------------------------- 
     908   !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  *** 
     909   !!    
     910   !!   Global sum of 1D array or a variable (integer, real or complex) 
     911   !!---------------------------------------------------------------------- 
     912   !! 
    1944913   SUBROUTINE mppsum_a_int( ktab, kdim ) 
    1945       !!---------------------------------------------------------------------- 
    1946       !!                  ***  routine mppsum_a_int  *** 
    1947       !! 
    1948       !! ** Purpose :   Global integer sum, 1D array case 
    1949       !! 
    1950914      !!---------------------------------------------------------------------- 
    1951915      INTEGER, INTENT(in   )                   ::   kdim   ! ??? 
    1952916      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab   ! ??? 
    1953       ! 
    1954917      INTEGER :: ierror 
    1955918      INTEGER, DIMENSION (kdim) ::  iwork 
    1956919      !!---------------------------------------------------------------------- 
    1957       ! 
    1958920      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
    1959       ! 
    1960921      ktab(:) = iwork(:) 
    1961       ! 
    1962922   END SUBROUTINE mppsum_a_int 
    1963  
    1964  
     923   !! 
    1965924   SUBROUTINE mppsum_int( ktab ) 
    1966925      !!---------------------------------------------------------------------- 
    1967       !!                 ***  routine mppsum_int  *** 
    1968       !! 
    1969       !! ** Purpose :   Global integer sum 
    1970       !! 
    1971       !!---------------------------------------------------------------------- 
    1972926      INTEGER, INTENT(inout) ::   ktab 
    1973       !! 
    1974927      INTEGER :: ierror, iwork 
    1975928      !!---------------------------------------------------------------------- 
    1976       ! 
    1977929      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 
    1978       ! 
    1979930      ktab = iwork 
    1980       ! 
    1981931   END SUBROUTINE mppsum_int 
    1982  
    1983  
    1984    SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 
    1985       !!---------------------------------------------------------------------- 
    1986       !!                 ***  routine mppmax_a_real  *** 
    1987       !! 
    1988       !! ** Purpose :   Maximum of a 1D array 
    1989       !! 
    1990       !!---------------------------------------------------------------------- 
    1991       REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab 
    1992       INTEGER                  , INTENT(in   ) ::   kdim 
    1993       INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom 
    1994       ! 
    1995       INTEGER :: ierror, localcomm 
    1996       REAL(wp), DIMENSION(kdim) ::  zwork 
    1997       !!---------------------------------------------------------------------- 
    1998       ! 
    1999       localcomm = mpi_comm_opa 
    2000       IF( PRESENT(kcom) ) localcomm = kcom 
    2001       ! 
    2002       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 
     932   !! 
     933   SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 
     934      !!----------------------------------------------------------------------- 
     935      INTEGER                  , INTENT(in   ) ::   kdim   ! size of ptab 
     936      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab   ! input array 
     937      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! specific communicator 
     938      INTEGER  ::   ierror, ilocalcomm    ! local integer 
     939      REAL(wp) ::   zwork(kdim)           ! local workspace 
     940      !!----------------------------------------------------------------------- 
     941      ilocalcomm = mpi_comm_opa 
     942      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     943      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 
    2003944      ptab(:) = zwork(:) 
    2004       ! 
    2005    END SUBROUTINE mppmax_a_real 
    2006  
    2007  
    2008    SUBROUTINE mppmax_real( ptab, kcom ) 
     945   END SUBROUTINE mppsum_a_real 
     946   !! 
     947   SUBROUTINE mppsum_real( ptab, kcom ) 
     948      !!----------------------------------------------------------------------- 
     949      REAL(wp)          , INTENT(inout)           ::   ptab   ! input scalar 
     950      INTEGER , OPTIONAL, INTENT(in   ) ::   kcom 
     951      INTEGER  ::   ierror, ilocalcomm 
     952      REAL(wp) ::   zwork 
     953      !!----------------------------------------------------------------------- 
     954      ilocalcomm = mpi_comm_opa 
     955      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     956      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 
     957      ptab = zwork 
     958   END SUBROUTINE mppsum_real 
     959   !! 
     960   SUBROUTINE mppsum_realdd( ytab, kcom ) 
     961      !!----------------------------------------------------------------------- 
     962      COMPLEX(wp)          , INTENT(inout) ::   ytab    ! input scalar 
     963      INTEGER    , OPTIONAL, INTENT(in   ) ::   kcom 
     964      INTEGER     ::   ierror, ilocalcomm 
     965      COMPLEX(wp) ::   zwork 
     966      !!----------------------------------------------------------------------- 
     967      ilocalcomm = mpi_comm_opa 
     968      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     969      CALL MPI_ALLREDUCE( ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 
     970      ytab = zwork 
     971   END SUBROUTINE mppsum_realdd 
     972   !! 
     973   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
     974      !!---------------------------------------------------------------------- 
     975      INTEGER                     , INTENT(in   ) ::   kdim   ! size of ytab 
     976      COMPLEX(wp), DIMENSION(kdim), INTENT(inout) ::   ytab   ! input array 
     977      INTEGER    , OPTIONAL       , INTENT(in   ) ::   kcom 
     978      INTEGER:: ierror, ilocalcomm    ! local integer 
     979      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace 
     980      !!----------------------------------------------------------------------- 
     981      ilocalcomm = mpi_comm_opa 
     982      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     983      CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 
     984      ytab(:) = zwork(:) 
     985   END SUBROUTINE mppsum_a_realdd 
     986    
     987 
     988   SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom  ) 
    2009989      !!---------------------------------------------------------------------- 
    2010990      !!                  ***  routine mppmax_real  *** 
    2011991      !! 
    2012       !! ** Purpose :   Maximum for each element of a 1D array 
    2013       !! 
    2014       !!---------------------------------------------------------------------- 
    2015       REAL(wp), INTENT(inout)           ::   ptab   ! ??? 
    2016       INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
    2017       !! 
    2018       INTEGER  ::   ierror, localcomm 
    2019       REAL(wp) ::   zwork 
    2020       !!---------------------------------------------------------------------- 
    2021       ! 
    2022       localcomm = mpi_comm_opa 
    2023       IF( PRESENT(kcom) )   localcomm = kcom 
    2024       ! 
    2025       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror ) 
    2026       ptab = zwork 
    2027       ! 
    2028    END SUBROUTINE mppmax_real 
    2029  
    2030  
    2031    SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom  ) 
    2032       !!---------------------------------------------------------------------- 
    2033       !!                  ***  routine mppmax_real  *** 
    2034       !! 
    2035       !! ** Purpose :   Maximum 
     992      !! ** Purpose :   Maximum across processor of each element of a 1D arrays 
    2036993      !! 
    2037994      !!---------------------------------------------------------------------- 
    … …  
    2040997      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! local communicator 
    2041998      !! 
    2042       INTEGER  ::   ierror, localcomm 
     999      INTEGER  ::   ierror, ilocalcomm 
    20431000      REAL(wp), DIMENSION(kdim) ::  zwork 
    20441001      !!---------------------------------------------------------------------- 
    2045       ! 
    2046       localcomm = mpi_comm_opa 
    2047       IF( PRESENT(kcom) )   localcomm = kcom 
    2048       ! 
    2049       CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 
     1002      ilocalcomm = mpi_comm_opa 
     1003      IF( PRESENT(kcom) )   ilocalcomm = kcom 
     1004      ! 
     1005      CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
    20501006      pt1d(:) = zwork(:) 
    20511007      ! 
    20521008   END SUBROUTINE mppmax_real_multiple 
    2053  
    2054  
    2055    SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    2056       !!---------------------------------------------------------------------- 
    2057       !!                 ***  routine mppmin_a_real  *** 
    2058       !! 
    2059       !! ** Purpose :   Minimum of REAL, array case 
    2060       !! 
    2061       !!----------------------------------------------------------------------- 
    2062       INTEGER , INTENT(in   )                  ::   kdim 
    2063       REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
    2064       INTEGER , INTENT(in   ), OPTIONAL        ::   kcom 
    2065       !! 
    2066       INTEGER :: ierror, localcomm 
    2067       REAL(wp), DIMENSION(kdim) ::   zwork 
    2068       !!----------------------------------------------------------------------- 
    2069       ! 
    2070       localcomm = mpi_comm_opa 
    2071       IF( PRESENT(kcom) ) localcomm = kcom 
    2072       ! 
    2073       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror ) 
    2074       ptab(:) = zwork(:) 
    2075       ! 
    2076    END SUBROUTINE mppmin_a_real 
    2077  
    2078  
    2079    SUBROUTINE mppmin_real( ptab, kcom ) 
    2080       !!---------------------------------------------------------------------- 
    2081       !!                  ***  routine mppmin_real  *** 
    2082       !! 
    2083       !! ** Purpose :   minimum of REAL, scalar case 
    2084       !! 
    2085       !!----------------------------------------------------------------------- 
    2086       REAL(wp), INTENT(inout)           ::   ptab        ! 
    2087       INTEGER , INTENT(in   ), OPTIONAL :: kcom 
    2088       !! 
    2089       INTEGER  ::   ierror 
    2090       REAL(wp) ::   zwork 
    2091       INTEGER :: localcomm 
    2092       !!----------------------------------------------------------------------- 
    2093       ! 
    2094       localcomm = mpi_comm_opa 
    2095       IF( PRESENT(kcom) )   localcomm = kcom 
    2096       ! 
    2097       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror ) 
    2098       ptab = zwork 
    2099       ! 
    2100    END SUBROUTINE mppmin_real 
    2101  
    2102  
    2103    SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 
    2104       !!---------------------------------------------------------------------- 
    2105       !!                  ***  routine mppsum_a_real  *** 
    2106       !! 
    2107       !! ** Purpose :   global sum, REAL ARRAY argument case 
    2108       !! 
    2109       !!----------------------------------------------------------------------- 
    2110       INTEGER , INTENT( in )                     ::   kdim      ! size of ptab 
    2111       REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array 
    2112       INTEGER , INTENT( in ), OPTIONAL           :: kcom 
    2113       !! 
    2114       INTEGER                   ::   ierror    ! temporary integer 
    2115       INTEGER                   ::   localcomm 
    2116       REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace 
    2117       !!----------------------------------------------------------------------- 
    2118       ! 
    2119       localcomm = mpi_comm_opa 
    2120       IF( PRESENT(kcom) )   localcomm = kcom 
    2121       ! 
    2122       CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror ) 
    2123       ptab(:) = zwork(:) 
    2124       ! 
    2125    END SUBROUTINE mppsum_a_real 
    2126  
    2127  
    2128    SUBROUTINE mppsum_real( ptab, kcom ) 
    2129       !!---------------------------------------------------------------------- 
    2130       !!                  ***  routine mppsum_real  *** 
    2131       !! 
    2132       !! ** Purpose :   global sum, SCALAR argument case 
    2133       !! 
    2134       !!----------------------------------------------------------------------- 
    2135       REAL(wp), INTENT(inout)           ::   ptab   ! input scalar 
    2136       INTEGER , INTENT(in   ), OPTIONAL ::   kcom 
    2137       !! 
    2138       INTEGER  ::   ierror, localcomm 
    2139       REAL(wp) ::   zwork 
    2140       !!----------------------------------------------------------------------- 
    2141       ! 
    2142       localcomm = mpi_comm_opa 
    2143       IF( PRESENT(kcom) ) localcomm = kcom 
    2144       ! 
    2145       CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror ) 
    2146       ptab = zwork 
    2147       ! 
    2148    END SUBROUTINE mppsum_real 
    2149  
    2150  
    2151    SUBROUTINE mppsum_realdd( ytab, kcom ) 
    2152       !!---------------------------------------------------------------------- 
    2153       !!                  ***  routine mppsum_realdd *** 
    2154       !! 
    2155       !! ** Purpose :   global sum in Massively Parallel Processing 
    2156       !!                SCALAR argument case for double-double precision 
    2157       !! 
    2158       !!----------------------------------------------------------------------- 
    2159       COMPLEX(wp), INTENT(inout)           ::   ytab    ! input scalar 
    2160       INTEGER    , INTENT(in   ), OPTIONAL ::   kcom 
    2161       ! 
    2162       INTEGER     ::   ierror 
    2163       INTEGER     ::   localcomm 
    2164       COMPLEX(wp) ::   zwork 
    2165       !!----------------------------------------------------------------------- 
    2166       ! 
    2167       localcomm = mpi_comm_opa 
    2168       IF( PRESENT(kcom) )   localcomm = kcom 
    2169       ! 
    2170       ! reduce local sums into global sum 
    2171       CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 
    2172       ytab = zwork 
    2173       ! 
    2174    END SUBROUTINE mppsum_realdd 
    2175  
    2176  
    2177    SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
    2178       !!---------------------------------------------------------------------- 
    2179       !!                  ***  routine mppsum_a_realdd  *** 
    2180       !! 
    2181       !! ** Purpose :   global sum in Massively Parallel Processing 
    2182       !!                COMPLEX ARRAY case for double-double precision 
    2183       !! 
    2184       !!----------------------------------------------------------------------- 
    2185       INTEGER                     , INTENT(in   ) ::   kdim   ! size of ytab 
    2186       COMPLEX(wp), DIMENSION(kdim), INTENT(inout) ::   ytab   ! input array 
    2187       INTEGER    , OPTIONAL       , INTENT(in   ) ::   kcom 
    2188       ! 
    2189       INTEGER:: ierror, localcomm    ! local integer 
    2190       COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace 
    2191       !!----------------------------------------------------------------------- 
    2192       ! 
    2193       localcomm = mpi_comm_opa 
    2194       IF( PRESENT(kcom) )   localcomm = kcom 
    2195       ! 
    2196       CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 
    2197       ytab(:) = zwork(:) 
    2198       ! 
    2199    END SUBROUTINE mppsum_a_realdd 
    22001009 
    22011010 
    … …  
    23501159      zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    23511160      ! 
    2352       CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_MAXLOC, MPI_COMM_OPA, ierror ) 
     1161      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 
    23531162      ! 
    23541163      pmax = zaout(1,1) 
    … …  
    26491458 
    26501459 
    2651    SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn ) 
    2652       !!--------------------------------------------------------------------- 
    2653       !!                   ***  routine mpp_lbc_north_3d  *** 
    2654       !! 
    2655       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2656       !!              in mpp configuration in case of jpn1 > 1 
    2657       !! 
    2658       !! ** Method  :   North fold condition and mpp with more than one proc 
    2659       !!              in i-direction require a specific treatment. We gather 
    2660       !!              the 4 northern lines of the global domain on 1 processor 
    2661       !!              and apply lbc north-fold on this sub array. Then we 
    2662       !!              scatter the north fold array back to the processors. 
    2663       !!---------------------------------------------------------------------- 
    2664       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied 
    2665       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    2666       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across the north fold 
    2667       ! 
    2668       INTEGER ::   ji, jj, jr, jk 
    2669       INTEGER ::   ipk                  ! 3rd dimension of the input array 
    2670       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    2671       INTEGER ::   ijpj, ijpjm1, ij, iproc 
    2672       INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    2673       INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    2674       INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    2675       !                                                              ! Workspace for message transfers avoiding mpi_allgather 
    2676       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
    2677       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk       
    2678       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
    2679       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    2680  
    2681       INTEGER :: istatus(mpi_status_size) 
    2682       INTEGER :: iflag 
    2683       !!---------------------------------------------------------------------- 
    2684       ! 
    2685       ipk = SIZE( pt3d, 3 ) 
    2686       ! 
    2687       ALLOCATE( ztab (jpiglo,4,ipk), znorthloc(jpi,4,ipk), zfoldwk(jpi,4,ipk), znorthgloio(jpi,4,ipk,jpni) ) 
    2688       ALLOCATE( ztabl(jpi   ,4,ipk), ztabr(jpi*jpmaxngh,4,ipk)   )  
    2689  
    2690       ijpj   = 4 
    2691       ijpjm1 = 3 
    2692       ! 
    2693       znorthloc(:,:,:) = 0._wp 
    2694       DO jk = 1, ipk 
    2695          DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d 
    2696             ij = jj - nlcj + ijpj 
    2697             znorthloc(:,ij,jk) = pt3d(:,jj,jk) 
    2698          END DO 
    2699       END DO 
    2700       ! 
    2701       !                                     ! Build in procs of ncomm_north the znorthgloio 
    2702       itaille = jpi * ipk * ijpj 
    2703  
    2704       IF ( l_north_nogather ) THEN 
    2705          ! 
    2706         ztabr(:,:,:) = 0._wp 
    2707         ztabl(:,:,:) = 0._wp 
    2708  
    2709         DO jk = 1, ipk 
    2710            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    2711               ij = jj - nlcj + ijpj 
    2712               DO ji = nfsloop, nfeloop 
    2713                  ztabl(ji,ij,jk) = pt3d(ji,jj,jk) 
    2714               END DO 
    2715            END DO 
    2716         END DO 
    2717  
    2718          DO jr = 1,nsndto 
    2719             IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    2720               CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    2721             ENDIF 
    2722          END DO 
    2723          DO jr = 1,nsndto 
    2724             iproc = nfipproc(isendto(jr),jpnj) 
    2725             IF(iproc /= -1) THEN 
    2726                ilei = nleit (iproc+1) 
    2727                ildi = nldit (iproc+1) 
    2728                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    2729             ENDIF 
    2730             IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    2731               CALL mpprecv(5, zfoldwk, itaille, iproc) 
    2732               DO jk = 1, ipk 
    2733                  DO jj = 1, ijpj 
    2734                     DO ji = ildi, ilei 
    2735                        ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) 
    2736                     END DO 
    2737                  END DO 
    2738               END DO 
    2739            ELSE IF( iproc == narea-1 ) THEN 
    2740               DO jk = 1, ipk 
    2741                  DO jj = 1, ijpj 
    2742                     DO ji = ildi, ilei 
    2743                        ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 
    2744                     END DO 
    2745                  END DO 
    2746               END DO 
    2747            ENDIF 
    2748          END DO 
    2749          IF (l_isend) THEN 
    2750             DO jr = 1,nsndto 
    2751                IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    2752                   CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 
    2753                ENDIF     
    2754             END DO 
    2755          ENDIF 
    2756          CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2757          DO jk = 1, ipk 
    2758             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    2759                ij = jj - nlcj + ijpj 
    2760                DO ji= 1, nlci 
    2761                   pt3d(ji,jj,jk) = ztabl(ji,ij,jk) 
    2762                END DO 
    2763             END DO 
    2764          END DO 
    2765          ! 
    2766       ELSE 
    2767          CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    2768             &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2769          ! 
    2770          ztab(:,:,:) = 0._wp 
    2771          DO jr = 1, ndim_rank_north         ! recover the global north array 
    2772             iproc = nrank_north(jr) + 1 
    2773             ildi  = nldit (iproc) 
    2774             ilei  = nleit (iproc) 
    2775             iilb  = nimppt(iproc) 
    2776             DO jk = 1, ipk 
    2777                DO jj = 1, ijpj 
    2778                   DO ji = ildi, ilei 
    2779                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
    2780                   END DO 
    2781                END DO 
    2782             END DO 
    2783          END DO 
    2784          CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    2785          ! 
    2786          DO jk = 1, ipk 
    2787             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    2788                ij = jj - nlcj + ijpj 
    2789                DO ji= 1, nlci 
    2790                   pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk) 
    2791                END DO 
    2792             END DO 
    2793          END DO 
    2794          ! 
    2795       ENDIF 
    2796       ! 
    2797       ! The ztab array has been either: 
    2798       !  a. Fully populated by the mpi_allgather operation or 
    2799       !  b. Had the active points for this domain and northern neighbours populated 
    2800       !     by peer to peer exchanges 
    2801       ! Either way the array may be folded by lbc_nfd and the result for the span of 
    2802       ! this domain will be identical. 
    2803       ! 
    2804       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    2805       DEALLOCATE( ztabl, ztabr )  
    2806       ! 
    2807    END SUBROUTINE mpp_lbc_north_3d 
    2808  
    2809  
    2810    SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn) 
    2811       !!--------------------------------------------------------------------- 
    2812       !!                   ***  routine mpp_lbc_north_2d  *** 
    2813       !! 
    2814       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2815       !!              in mpp configuration in case of jpn1 > 1 (for 2d array ) 
    2816       !! 
    2817       !! ** Method  :   North fold condition and mpp with more than one proc 
    2818       !!              in i-direction require a specific treatment. We gather 
    2819       !!              the 4 northern lines of the global domain on 1 processor 
    2820       !!              and apply lbc north-fold on this sub array. Then we 
    2821       !!              scatter the north fold array back to the processors. 
    2822       !! 
    2823       !!---------------------------------------------------------------------- 
    2824       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied 
    2825       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
    2826       !                                                          !   = T ,  U , V , F or W  gridpoints 
    2827       REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
    2828       !!                                                             ! =  1. , the sign is kept 
    2829       INTEGER ::   ji, jj, jr 
    2830       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    2831       INTEGER ::   ijpj, ijpjm1, ij, iproc 
    2832       INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    2833       INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    2834       INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    2835       !                                                              ! Workspace for message transfers avoiding mpi_allgather 
    2836       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztab 
    2837       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk       
    2838       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE   :: znorthgloio 
    2839       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    2840       INTEGER :: istatus(mpi_status_size) 
    2841       INTEGER :: iflag 
    2842       !!---------------------------------------------------------------------- 
    2843       ! 
    2844       ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) ) 
    2845       ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) )  
    2846       ! 
    2847       ijpj   = 4 
    2848       ijpjm1 = 3 
    2849       ! 
    2850       DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d 
    2851          ij = jj - nlcj + ijpj 
    2852          znorthloc(:,ij) = pt2d(:,jj) 
    2853       END DO 
    2854  
    2855       !                                     ! Build in procs of ncomm_north the znorthgloio 
    2856       itaille = jpi * ijpj 
    2857       IF ( l_north_nogather ) THEN 
    2858          ! 
    2859          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
    2860          ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    2861          ! 
    2862          ztabr(:,:) = 0 
    2863          ztabl(:,:) = 0 
    2864  
    2865          DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    2866             ij = jj - nlcj + ijpj 
    2867               DO ji = nfsloop, nfeloop 
    2868                ztabl(ji,ij) = pt2d(ji,jj) 
    2869             END DO 
    2870          END DO 
    2871  
    2872          DO jr = 1,nsndto 
    2873             IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    2874                CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    2875             ENDIF 
    2876          END DO 
    2877          DO jr = 1,nsndto 
    2878             iproc = nfipproc(isendto(jr),jpnj) 
    2879             IF( iproc /= -1 ) THEN 
    2880                ilei = nleit (iproc+1) 
    2881                ildi = nldit (iproc+1) 
    2882                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    2883             ENDIF 
    2884             IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    2885               CALL mpprecv(5, zfoldwk, itaille, iproc) 
    2886               DO jj = 1, ijpj 
    2887                  DO ji = ildi, ilei 
    2888                     ztabr(iilb+ji,jj) = zfoldwk(ji,jj) 
    2889                  END DO 
    2890               END DO 
    2891             ELSEIF( iproc == narea-1 ) THEN 
    2892               DO jj = 1, ijpj 
    2893                  DO ji = ildi, ilei 
    2894                     ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 
    2895                  END DO 
    2896               END DO 
    2897             ENDIF 
    2898          END DO 
    2899          IF(l_isend) THEN 
    2900             DO jr = 1,nsndto 
    2901                IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    2902                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    2903                ENDIF 
    2904             END DO 
    2905          ENDIF 
    2906          CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition 
    2907          ! 
    2908          DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    2909             ij = jj - nlcj + ijpj 
    2910             DO ji = 1, nlci 
    2911                pt2d(ji,jj) = ztabl(ji,ij) 
    2912             END DO 
    2913          END DO 
    2914          ! 
    2915       ELSE 
    2916          CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        & 
    2917             &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    2918          ! 
    2919          ztab(:,:) = 0._wp 
    2920          DO jr = 1, ndim_rank_north            ! recover the global north array 
    2921             iproc = nrank_north(jr) + 1 
    2922             ildi = nldit (iproc) 
    2923             ilei = nleit (iproc) 
    2924             iilb = nimppt(iproc) 
    2925             DO jj = 1, ijpj 
    2926                DO ji = ildi, ilei 
    2927                   ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr) 
    2928                END DO 
    2929             END DO 
    2930          END DO 
    2931          CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition 
    2932          ! 
    2933          DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    2934             ij = jj - nlcj + ijpj 
    2935             DO ji = 1, nlci 
    2936                pt2d(ji,jj) = ztab(ji+nimpp-1,ij) 
    2937             END DO 
    2938          END DO 
    2939          ! 
    2940       ENDIF 
    2941       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    2942       DEALLOCATE( ztabl, ztabr )  
    2943       ! 
    2944    END SUBROUTINE mpp_lbc_north_2d 
    2945  
    2946  
    2947    SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, kfld ) 
    2948       !!--------------------------------------------------------------------- 
    2949       !!                   ***  routine mpp_lbc_north_2d  *** 
    2950       !! 
    2951       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    2952       !!              in mpp configuration in case of jpn1 > 1 
    2953       !!              (for multiple 2d arrays ) 
    2954       !! 
    2955       !! ** Method  :   North fold condition and mpp with more than one proc 
    2956       !!              in i-direction require a specific treatment. We gather 
    2957       !!              the 4 northern lines of the global domain on 1 processor 
    2958       !!              and apply lbc north-fold on this sub array. Then we 
    2959       !!              scatter the north fold array back to the processors. 
    2960       !! 
    2961       !!---------------------------------------------------------------------- 
    2962       TYPE( arrayptr ), DIMENSION(:), INTENT(inout) ::   pt2d_array   ! pointer array of 2D fields 
    2963       CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type      ! nature of pt2d grid-points 
    2964       REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn         ! sign used across the north fold  
    2965       INTEGER                       , INTENT(in   ) ::   kfld         ! number of variables contained in pt2d 
    2966       ! 
    2967       INTEGER ::   ji, jj, jr, jk 
    2968       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    2969       INTEGER ::   ijpj, ijpjm1, ij, iproc, iflag 
    2970       INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather 
    2971       INTEGER                            ::   ml_err      ! for mpi_isend when avoiding mpi_allgather 
    2972       INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat     ! for mpi_isend when avoiding mpi_allgather 
    2973       !                                                   ! Workspace for message transfers avoiding mpi_allgather 
    2974       INTEGER :: istatus(mpi_status_size) 
    2975       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
    2976       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
    2977       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
    2978       REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
    2979       !!---------------------------------------------------------------------- 
    2980       ! 
    2981       ALLOCATE( ztab(jpiglo,4,kfld), znorthloc  (jpi,4,kfld),        & 
    2982          &      zfoldwk(jpi,4,kfld), znorthgloio(jpi,4,kfld,jpni),   & 
    2983          &      ztabl  (jpi,4,kfld), ztabr(jpi*jpmaxngh, 4,kfld)   ) 
    2984       ! 
    2985       ijpj   = 4 
    2986       ijpjm1 = 3 
    2987       ! 
    2988        
    2989       DO jk = 1, kfld 
    2990          DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
    2991             ij = jj - nlcj + ijpj 
    2992             znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
    2993          END DO 
    2994       END DO 
    2995       !                                     ! Build in procs of ncomm_north the znorthgloio 
    2996       itaille = jpi * ijpj 
    2997                                                                    
    2998       IF ( l_north_nogather ) THEN 
    2999          ! 
    3000          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
    3001          ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    3002          ! 
    3003          ztabr(:,:,:) = 0._wp 
    3004          ztabl(:,:,:) = 0._wp 
    3005  
    3006          DO jk = 1, kfld 
    3007             DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    3008                ij = jj - nlcj + ijpj 
    3009                DO ji = nfsloop, nfeloop 
    3010                   ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
    3011                END DO 
    3012             END DO 
    3013          END DO 
    3014  
    3015          DO jr = 1, nsndto 
    3016             IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    3017                CALL mppsend(5, znorthloc, itaille*kfld, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "kfld" times 
    3018             ENDIF 
    3019          END DO 
    3020          DO jr = 1, nsndto 
    3021             iproc = nfipproc(isendto(jr),jpnj) 
    3022             IF( iproc /= -1 ) THEN 
    3023                ilei = nleit (iproc+1) 
    3024                ildi = nldit (iproc+1) 
    3025                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    3026             ENDIF 
    3027             IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    3028               CALL mpprecv(5, zfoldwk, itaille*kfld, iproc) ! Buffer expanded "kfld" times 
    3029               DO jk = 1 , kfld 
    3030                  DO jj = 1, ijpj 
    3031                     DO ji = ildi, ilei 
    3032                        ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
    3033                     END DO 
    3034                  END DO 
    3035               END DO 
    3036             ELSEIF ( iproc == narea-1 ) THEN 
    3037               DO jk = 1, kfld 
    3038                  DO jj = 1, ijpj 
    3039                     DO ji = ildi, ilei 
    3040                           ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
    3041                     END DO 
    3042                  END DO 
    3043               END DO 
    3044             ENDIF 
    3045          END DO 
    3046          IF( l_isend ) THEN 
    3047             DO jr = 1, nsndto 
    3048                IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    3049                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    3050                ENDIF 
    3051             END DO 
    3052          ENDIF 
    3053          ! 
    3054          DO ji = 1, kfld     ! Loop to manage 3D variables 
    3055             CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
    3056          END DO 
    3057          ! 
    3058          DO jk = 1, kfld 
    3059             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    3060                ij = jj - nlcj + ijpj 
    3061                DO ji = 1, nlci 
    3062                   pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
    3063                END DO 
    3064             END DO 
    3065          END DO 
    3066           
    3067          ! 
    3068       ELSE 
    3069          ! 
    3070          CALL MPI_ALLGATHER( znorthloc  , itaille*kfld, MPI_DOUBLE_PRECISION,        & 
    3071             &                znorthgloio, itaille*kfld, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    3072          ! 
    3073          ztab(:,:,:) = 0._wp 
    3074          DO jk = 1, kfld 
    3075             DO jr = 1, ndim_rank_north            ! recover the global north array 
    3076                iproc = nrank_north(jr) + 1 
    3077                ildi = nldit (iproc) 
    3078                ilei = nleit (iproc) 
    3079                iilb = nimppt(iproc) 
    3080                DO jj = 1, ijpj 
    3081                   DO ji = ildi, ilei 
    3082                      ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
    3083                   END DO 
    3084                END DO 
    3085             END DO 
    3086          END DO 
    3087           
    3088          DO ji = 1, kfld 
    3089             CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
    3090          END DO 
    3091          ! 
    3092          DO jk = 1, kfld 
    3093             DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
    3094                ij = jj - nlcj + ijpj 
    3095                DO ji = 1, nlci 
    3096                   pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
    3097                END DO 
    3098             END DO 
    3099          END DO 
    3100          ! 
    3101          ! 
    3102       ENDIF 
    3103       DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
    3104       DEALLOCATE( ztabl, ztabr ) 
    3105       ! 
    3106    END SUBROUTINE mpp_lbc_north_2d_multiple 
    3107  
    3108  
    31091460   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    31101461      !!--------------------------------------------------------------------- 
    … …  
    31651516      ! 2. North-Fold boundary conditions 
    31661517      ! ---------------------------------- 
    3167       CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
     1518!!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 
    31681519 
    31691520      ij = jpr2dj 
    … …  
    31791530      ! 
    31801531   END SUBROUTINE mpp_lbc_north_e 
    3181  
    3182  
    3183    SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 
    3184       !!---------------------------------------------------------------------- 
    3185       !!                  ***  routine mpp_lnk_bdy_3d  *** 
    3186       !! 
    3187       !! ** Purpose :   Message passing management 
    3188       !! 
    3189       !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
    3190       !!      between processors following neighboring subdomains. 
    3191       !!            domain parameters 
    3192       !!                    nlci   : first dimension of the local subdomain 
    3193       !!                    nlcj   : second dimension of the local subdomain 
    3194       !!                    nbondi_bdy : mark for "east-west local boundary" 
    3195       !!                    nbondj_bdy : mark for "north-south local boundary" 
    3196       !!                    noea   : number for local neighboring processors  
    3197       !!                    nowe   : number for local neighboring processors 
    3198       !!                    noso   : number for local neighboring processors 
    3199       !!                    nono   : number for local neighboring processors 
    3200       !! 
    3201       !! ** Action  :   ptab with update value at its periphery 
    3202       !! 
    3203       !!---------------------------------------------------------------------- 
    3204       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    3205       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type  ! nature of ptab grid point 
    3206       REAL(wp)                  , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    3207       INTEGER                   , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    3208       ! 
    3209       INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    3210       INTEGER  ::   ipk                        ! 3rd dimension of the input array 
    3211       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    3212       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    3213       REAL(wp) ::   zland                      ! local scalar 
    3214       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    3215       ! 
    3216       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    3217       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
    3218       !!---------------------------------------------------------------------- 
    3219       ! 
    3220       ipk = SIZE( ptab, 3 ) 
    3221       !       
    3222       ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2),   & 
    3223          &      zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2)  ) 
    3224  
    3225       zland = 0._wp 
    3226  
    3227       ! 1. standard boundary treatment 
    3228       ! ------------------------------ 
    3229       !                                   ! East-West boundaries 
    3230       !                                        !* Cyclic 
    3231       IF( nbondi == 2) THEN 
    3232          IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
    3233             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    3234             ptab(jpi,:,:) = ptab(  2  ,:,:) 
    3235          ELSE 
    3236             IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point 
    3237             ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north 
    3238          ENDIF 
    3239       ELSEIF(nbondi == -1) THEN 
    3240          IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland       ! south except F-point 
    3241       ELSEIF(nbondi == 1) THEN 
    3242          ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north 
    3243       ENDIF                                     !* closed 
    3244  
    3245       IF (nbondj == 2 .OR. nbondj == -1) THEN 
    3246         IF( .NOT. cd_type == 'F' )   ptab(:,1:jprecj,:) = zland       ! south except F-point 
    3247       ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
    3248         ptab(:,nlcj-jprecj+1:jpj,:) = zland       ! north 
    3249       ENDIF 
    3250       ! 
    3251       ! 2. East and west directions exchange 
    3252       ! ------------------------------------ 
    3253       ! we play with the neigbours AND the row number because of the periodicity  
    3254       ! 
    3255       SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
    3256       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    3257          iihom = nlci-nreci 
    3258          DO jl = 1, jpreci 
    3259             zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
    3260             zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
    3261          END DO 
    3262       END SELECT 
    3263       ! 
    3264       !                           ! Migrations 
    3265       imigr = jpreci * jpj * ipk 
    3266       ! 
    3267       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3268       CASE ( -1 ) 
    3269          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    3270       CASE ( 0 ) 
    3271          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    3272          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    3273       CASE ( 1 ) 
    3274          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    3275       END SELECT 
    3276       ! 
    3277       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3278       CASE ( -1 ) 
    3279          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    3280       CASE ( 0 ) 
    3281          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    3282          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    3283       CASE ( 1 ) 
    3284          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
    3285       END SELECT 
    3286       ! 
    3287       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3288       CASE ( -1 ) 
    3289          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3290       CASE ( 0 ) 
    3291          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3292          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3293       CASE ( 1 ) 
    3294          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3295       END SELECT 
    3296       ! 
    3297       !                           ! Write Dirichlet lateral conditions 
    3298       iihom = nlci-jpreci 
    3299       ! 
    3300       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3301       CASE ( -1 ) 
    3302          DO jl = 1, jpreci 
    3303             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    3304          END DO 
    3305       CASE ( 0 ) 
    3306          DO jl = 1, jpreci 
    3307             ptab(      jl,:,:) = zt3we(:,jl,:,2) 
    3308             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
    3309          END DO 
    3310       CASE ( 1 ) 
    3311          DO jl = 1, jpreci 
    3312             ptab(      jl,:,:) = zt3we(:,jl,:,2) 
    3313          END DO 
    3314       END SELECT 
    3315  
    3316       ! 3. North and south directions 
    3317       ! ----------------------------- 
    3318       ! always closed : we play only with the neigbours 
    3319       ! 
    3320       IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    3321          ijhom = nlcj-nrecj 
    3322          DO jl = 1, jprecj 
    3323             zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
    3324             zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
    3325          END DO 
    3326       ENDIF 
    3327       ! 
    3328       !                           ! Migrations 
    3329       imigr = jprecj * jpi * ipk 
    3330       ! 
    3331       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3332       CASE ( -1 ) 
    3333          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    3334       CASE ( 0 ) 
    3335          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    3336          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    3337       CASE ( 1 ) 
    3338          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    3339       END SELECT 
    3340       ! 
    3341       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3342       CASE ( -1 ) 
    3343          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    3344       CASE ( 0 ) 
    3345          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    3346          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    3347       CASE ( 1 ) 
    3348          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
    3349       END SELECT 
    3350       ! 
    3351       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3352       CASE ( -1 ) 
    3353          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3354       CASE ( 0 ) 
    3355          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3356          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    3357       CASE ( 1 ) 
    3358          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    3359       END SELECT 
    3360       ! 
    3361       !                           ! Write Dirichlet lateral conditions 
    3362       ijhom = nlcj-jprecj 
    3363       ! 
    3364       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3365       CASE ( -1 ) 
    3366          DO jl = 1, jprecj 
    3367             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    3368          END DO 
    3369       CASE ( 0 ) 
    3370          DO jl = 1, jprecj 
    3371             ptab(:,jl      ,:) = zt3sn(:,jl,:,2) 
    3372             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
    3373          END DO 
    3374       CASE ( 1 ) 
    3375          DO jl = 1, jprecj 
    3376             ptab(:,jl,:) = zt3sn(:,jl,:,2) 
    3377          END DO 
    3378       END SELECT 
    3379  
    3380       ! 4. north fold treatment 
    3381       ! ----------------------- 
    3382       ! 
    3383       IF( npolj /= 0) THEN 
    3384          ! 
    3385          SELECT CASE ( jpni ) 
    3386          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    3387          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    3388          END SELECT 
    3389          ! 
    3390       ENDIF 
    3391       ! 
    3392       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  ) 
    3393       ! 
    3394    END SUBROUTINE mpp_lnk_bdy_3d 
    3395  
    3396  
    3397    SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 
    3398       !!---------------------------------------------------------------------- 
    3399       !!                  ***  routine mpp_lnk_bdy_2d  *** 
    3400       !! 
    3401       !! ** Purpose :   Message passing management 
    3402       !! 
    3403       !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries  
    3404       !!      between processors following neighboring subdomains. 
    3405       !!            domain parameters 
    3406       !!                    nlci   : first dimension of the local subdomain 
    3407       !!                    nlcj   : second dimension of the local subdomain 
    3408       !!                    nbondi_bdy : mark for "east-west local boundary" 
    3409       !!                    nbondj_bdy : mark for "north-south local boundary" 
    3410       !!                    noea   : number for local neighboring processors  
    3411       !!                    nowe   : number for local neighboring processors 
    3412       !!                    noso   : number for local neighboring processors 
    3413       !!                    nono   : number for local neighboring processors 
    3414       !! 
    3415       !! ** Action  :   ptab with update value at its periphery 
    3416       !! 
    3417       !!---------------------------------------------------------------------- 
    3418       REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    3419       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    3420       REAL(wp)                        , INTENT(in   ) ::   psgn     ! sign used across the north fold boundary 
    3421       INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    3422       ! 
    3423       INTEGER  ::   ji, jj, jl                 ! dummy loop indices 
    3424       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    3425       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    3426       REAL(wp) ::   zland 
    3427       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    3428       ! 
    3429       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
    3430       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
    3431       !!---------------------------------------------------------------------- 
    3432  
    3433       ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
    3434          &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
    3435  
    3436       zland = 0._wp 
    3437  
    3438       ! 1. standard boundary treatment 
    3439       ! ------------------------------ 
    3440       !                                   ! East-West boundaries 
    3441       !                                         !* Cyclic 
    3442       IF( nbondi == 2 ) THEN 
    3443          IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
    3444             ptab( 1 ,:) = ptab(jpim1,:) 
    3445             ptab(jpi,:) = ptab(  2  ,:) 
    3446          ELSE 
    3447             IF(.NOT.cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point 
    3448                                        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    3449          ENDIF 
    3450       ELSEIF(nbondi == -1) THEN 
    3451          IF(.NOT.cd_type == 'F' )      ptab(     1       :jpreci,:) = zland    ! south except F-point 
    3452       ELSEIF(nbondi == 1) THEN 
    3453                                        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north 
    3454       ENDIF 
    3455       !                                      !* closed 
    3456       IF( nbondj == 2 .OR. nbondj == -1 ) THEN 
    3457          IF( .NOT.cd_type == 'F' )    ptab(:,     1       :jprecj) = zland    ! south except F-point 
    3458       ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 
    3459                                       ptab(:,nlcj-jprecj+1:jpj   ) = zland    ! north 
    3460       ENDIF 
    3461       ! 
    3462       ! 2. East and west directions exchange 
    3463       ! ------------------------------------ 
    3464       ! we play with the neigbours AND the row number because of the periodicity  
    3465       ! 
    3466       SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions 
    3467       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    3468          iihom = nlci-nreci 
    3469          DO jl = 1, jpreci 
    3470             zt2ew(:,jl,1) = ptab(jpreci+jl,:) 
    3471             zt2we(:,jl,1) = ptab(iihom +jl,:) 
    3472          END DO 
    3473       END SELECT 
    3474       ! 
    3475       !                           ! Migrations 
    3476       imigr = jpreci * jpj 
    3477       ! 
    3478       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3479       CASE ( -1 ) 
    3480          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    3481       CASE ( 0 ) 
    3482          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    3483          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    3484       CASE ( 1 ) 
    3485          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    3486       END SELECT 
    3487       ! 
    3488       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3489       CASE ( -1 ) 
    3490          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    3491       CASE ( 0 ) 
    3492          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    3493          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    3494       CASE ( 1 ) 
    3495          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
    3496       END SELECT 
    3497       ! 
    3498       SELECT CASE ( nbondi_bdy(ib_bdy) ) 
    3499       CASE ( -1 ) 
    3500          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    3501       CASE ( 0 ) 
    3502          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    3503          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 
    3504       CASE ( 1 ) 
    3505          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    3506       END SELECT 
    3507       ! 
    3508       !                           ! Write Dirichlet lateral conditions 
    3509       iihom = nlci-jpreci 
    3510       ! 
    3511       SELECT CASE ( nbondi_bdy_b(ib_bdy) ) 
    3512       CASE ( -1 ) 
    3513          DO jl = 1, jpreci 
    3514             ptab(iihom+jl,:) = zt2ew(:,jl,2) 
    3515          END DO 
    3516       CASE ( 0 ) 
    3517          DO jl = 1, jpreci 
    3518             ptab(jl      ,:) = zt2we(:,jl,2) 
    3519             ptab(iihom+jl,:) = zt2ew(:,jl,2) 
    3520          END DO 
    3521       CASE ( 1 ) 
    3522          DO jl = 1, jpreci 
    3523             ptab(jl      ,:) = zt2we(:,jl,2) 
    3524          END DO 
    3525       END SELECT 
    3526  
    3527  
    3528       ! 3. North and south directions 
    3529       ! ----------------------------- 
    3530       ! always closed : we play only with the neigbours 
    3531       ! 
    3532       IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    3533          ijhom = nlcj-nrecj 
    3534          DO jl = 1, jprecj 
    3535             zt2sn(:,jl,1) = ptab(:,ijhom +jl) 
    3536             zt2ns(:,jl,1) = ptab(:,jprecj+jl) 
    3537          END DO 
    3538       ENDIF 
    3539       ! 
    3540       !                           ! Migrations 
    3541       imigr = jprecj * jpi 
    3542       ! 
    3543       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3544       CASE ( -1 ) 
    3545          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    3546       CASE ( 0 ) 
    3547          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    3548          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    3549       CASE ( 1 ) 
    3550          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    3551       END SELECT 
    3552       ! 
    3553       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3554       CASE ( -1 ) 
    3555          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    3556       CASE ( 0 ) 
    3557          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    3558          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    3559       CASE ( 1 ) 
    3560          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
    3561       END SELECT 
    3562       ! 
    3563       SELECT CASE ( nbondj_bdy(ib_bdy) ) 
    3564       CASE ( -1 ) 
    3565          IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    3566       CASE ( 0 ) 
    3567          IF(l_isend) CALL mpi_wait (ml_req1, ml_stat, ml_err ) 
    3568          IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
    3569       CASE ( 1 ) 
    3570          IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    3571       END SELECT 
    3572       ! 
    3573       !                           ! Write Dirichlet lateral conditions 
    3574       ijhom = nlcj-jprecj 
    3575       ! 
    3576       SELECT CASE ( nbondj_bdy_b(ib_bdy) ) 
    3577       CASE ( -1 ) 
    3578          DO jl = 1, jprecj 
    3579             ptab(:,ijhom+jl) = zt2ns(:,jl,2) 
    3580          END DO 
    3581       CASE ( 0 ) 
    3582          DO jl = 1, jprecj 
    3583             ptab(:,jl      ) = zt2sn(:,jl,2) 
    3584             ptab(:,ijhom+jl) = zt2ns(:,jl,2) 
    3585          END DO 
    3586       CASE ( 1 ) 
    3587          DO jl = 1, jprecj 
    3588             ptab(:,jl) = zt2sn(:,jl,2) 
    3589          END DO 
    3590       END SELECT 
    3591  
    3592       ! 4. north fold treatment 
    3593       ! ----------------------- 
    3594       ! 
    3595       IF( npolj /= 0) THEN 
    3596          ! 
    3597          SELECT CASE ( jpni ) 
    3598          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    3599          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
    3600          END SELECT 
    3601          ! 
    3602       ENDIF 
    3603       ! 
    3604       DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we  ) 
    3605       ! 
    3606    END SUBROUTINE mpp_lnk_bdy_2d 
    36071532 
    36081533 
    … …  
    36661591   END SUBROUTINE mpi_init_opa 
    36671592 
    3668    SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 
     1593 
     1594   SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype ) 
    36691595      !!--------------------------------------------------------------------- 
    36701596      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD 
    … …  
    36801606      INTEGER  :: ji, ztmp           ! local scalar 
    36811607      !!--------------------------------------------------------------------- 
    3682  
     1608      ! 
    36831609      ztmp = itype   ! avoid compilation warning 
    3684  
     1610      ! 
    36851611      DO ji=1,ilen 
    36861612      ! Compute ydda + yddb using Knuth's trick. 
    … …  
    36931619         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp ) 
    36941620      END DO 
    3695  
     1621      ! 
    36961622   END SUBROUTINE DDPDD_MPI 
    36971623 
    … …  
    37631689      END DO 
    37641690 
    3765  
    37661691      ! 2. North-Fold boundary conditions 
    37671692      ! ---------------------------------- 
    3768       CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
     1693!!gm ERROR      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 
    37691694 
    37701695      ij = ipr2dj 
    … …  
    38091734      ! 
    38101735      INTEGER  ::   jl   ! dummy loop indices 
    3811       INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
    3812       INTEGER  ::   ipreci, iprecj             ! temporary integers 
     1736      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
     1737      INTEGER  ::   ipreci, iprecj             !   -       - 
    38131738      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    38141739      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    38151740      !! 
    3816       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 
    3817       REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 
    3818       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 
    3819       REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 
     1741      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) ::   r2dns, r2dsn 
     1742      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) ::   r2dwe, r2dew 
    38201743      !!---------------------------------------------------------------------- 
    38211744 
    … …  
    38451768         ! 
    38461769         SELECT CASE ( jpni ) 
    3847          CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
    3848          CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  ) 
     1770!!gm ERROR         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 
     1771!!gm ERROR         CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  ) 
    38491772         END SELECT 
    38501773         ! 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90

    r6140 r8586  
    1414   !!   fin_date     : Compute the final date YYYYMMDD.HHMMSS 
    1515   !!---------------------------------------------------------------------- 
    16    !! * Modules used 
    1716   USE wrk_nemo                 ! Memory Allocation 
    1817   USE par_kind                 ! Precision variables 
    … …  
    3635 
    3736   IMPLICIT NONE 
    38  
    39    !! * Routine accessibility 
    4037   PRIVATE 
    41    PUBLIC dia_obs_init, &  ! Initialize and read observations 
    42       &   dia_obs,      &  ! Compute model equivalent to observations 
    43       &   dia_obs_wri,  &  ! Write model equivalent to observations 
    44       &   dia_obs_dealloc, &  ! Deallocate dia_obs data 
    45       &   calc_date           ! Compute the date of a timestep 
     38 
     39   PUBLIC dia_obs_init     ! Initialize and read observations 
     40   PUBLIC dia_obs          ! Compute model equivalent to observations 
     41   PUBLIC dia_obs_wri      ! Write model equivalent to observations 
     42   PUBLIC dia_obs_dealloc  ! Deallocate dia_obs data 
     43   PUBLIC calc_date        ! Compute the date of a timestep 
    4644 
    4745   !! * Module variables 
    … …  
    5149   INTEGER :: nn_1dint       !: Vertical interpolation method 
    5250   INTEGER :: nn_2dint       !: Horizontal interpolation method 
    53    INTEGER, DIMENSION(imaxavtypes) :: & 
    54       & nn_profdavtypes      !: Profile data types representing a daily average 
     51   INTEGER, DIMENSION(imaxavtypes) ::   nn_profdavtypes   !: Profile data types representing a daily average 
    5552   INTEGER :: nproftypes     !: Number of profile obs types 
    5653   INTEGER :: nsurftypes     !: Number of surface obs types 
    57    INTEGER, DIMENSION(:), ALLOCATABLE :: & 
    58       & nvarsprof, &         !: Number of profile variables 
    59       & nvarssurf            !: Number of surface variables 
    60    INTEGER, DIMENSION(:), ALLOCATABLE :: & 
    61       & nextrprof, &         !: Number of profile extra variables 
    62       & nextrsurf            !: Number of surface extra variables 
    63    INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:) :: sstbias_type !SST bias type     
    64    TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: & 
    65       & surfdata, &          !: Initial surface data 
    66       & surfdataqc           !: Surface data after quality control 
    67    TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: & 
    68       & profdata, &          !: Initial profile data 
    69       & profdataqc           !: Profile data after quality control 
    70  
    71    CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: & 
    72       & cobstypesprof, &     !: Profile obs types 
    73       & cobstypessurf        !: Surface obs types 
     54   INTEGER, DIMENSION(:), ALLOCATABLE ::   nvarsprof, nvarssurf   !: Number of profile & surface variables 
     55   INTEGER, DIMENSION(:), ALLOCATABLE ::   nextrprof, nextrsurf   !: Number of profile & surface extra variables 
     56   INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sstbias_type   !: SST bias type     
     57   TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) ::   surfdata, surfdataqc   !: Initial surface data before & after quality control 
     58   TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) ::   profdata, profdataqc   !: Initial profile data before & after quality control 
     59 
     60   CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE ::   cobstypesprof, cobstypessurf   !: Profile & surface obs types 
    7461 
    7562   !!---------------------------------------------------------------------- 
    … …  
    7865   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    7966   !!---------------------------------------------------------------------- 
    80  
    8167CONTAINS 
    8268 
    … …  
    9985      !!        !  15-02  (M. Martin) Simplification of namelist and code 
    10086      !!---------------------------------------------------------------------- 
    101  
    102       IMPLICIT NONE 
    103  
    104       !! * Local declarations 
    105       INTEGER, PARAMETER :: & 
    106          & jpmaxnfiles = 1000    ! Maximum number of files for each obs type 
    107       INTEGER, DIMENSION(:), ALLOCATABLE :: & 
    108          & ifilesprof, &         ! Number of profile files 
    109          & ifilessurf            ! Number of surface files 
     87      INTEGER, PARAMETER ::   jpmaxnfiles = 1000    ! Maximum number of files for each obs type 
     88      INTEGER, DIMENSION(:), ALLOCATABLE ::   ifilesprof, ifilessurf   ! Number of profile & surface files 
    11089      INTEGER :: ios             ! Local integer output status for namelist read 
    11190      INTEGER :: jtype           ! Counter for obs types 
    … …  
    134113      LOGICAL :: ln_nea          ! Logical switch to remove obs near land 
    135114      LOGICAL :: ln_altbias      ! Logical switch for altimeter bias 
    136       LOGICAL :: ln_sstbias     !: Logical switch for bias corection of SST  
     115      LOGICAL :: ln_sstbias      ! Logical switch for bias corection of SST  
    137116      LOGICAL :: ln_ignmis       ! Logical switch for ignoring missing files 
    138117      LOGICAL :: ln_s_at_t       ! Logical switch to compute model S at T obs 
    … …  
    291270            END DO 
    292271         ENDIF 
    293 #if defined key_lim2 || defined key_lim3 
     272#if defined key_lim3 
    294273         IF (ln_sic) THEN 
    295274            jtype = jtype + 1 
    … …  
    501480   END SUBROUTINE dia_obs_init 
    502481 
     482 
    503483   SUBROUTINE dia_obs( kstp ) 
    504484      !!---------------------------------------------------------------------- 
    … …  
    525505      !!        !  15-08  (M. Martin) Combined surface/profile routines. 
    526506      !!---------------------------------------------------------------------- 
    527       !! * Modules used 
    528       USE dom_oce, ONLY : &             ! Ocean space and time domain variables 
    529          & gdept_n,       &       
    530          & gdept_1d       
    531       USE phycst, ONLY : &              ! Physical constants 
    532          & rday                          
    533       USE oce, ONLY : &                 ! Ocean dynamics and tracers variables 
    534          & tsn,  &              
    535          & un, vn, & 
    536          & sshn   
    537       USE phycst, ONLY : &         ! Physical constants 
    538          & rday 
     507      USE dom_oce, ONLY : gdept_n, gdept_1d   ! Ocean space and time domain variables 
     508      USE phycst , ONLY : rday                ! Physical constants 
     509      USE oce    , ONLY : tsn, un, vn, sshn   ! Ocean dynamics and tracers variables 
     510      USE phycst , ONLY : rday                ! Physical constants 
    539511#if defined  key_lim3 
    540       USE ice, ONLY : &            ! LIM3 Ice model variables 
    541          & frld 
    542 #endif 
    543 #if defined key_lim2 
    544       USE ice_2, ONLY : &          ! LIM2 Ice model variables 
    545          & frld 
     512      USE ice    , ONLY : at_i                ! LIM3 Ice model variables 
    546513#endif 
    547514      IMPLICIT NONE 
    … …  
    567534         & zgphi1,    &            ! Model latitudes for prof variable 1 
    568535         & zgphi2                  ! Model latitudes for prof variable 2 
    569 #if ! defined key_lim2 && ! defined key_lim3 
    570       REAL(wp), POINTER, DIMENSION(:,:) :: frld 
     536#if ! defined key_lim3 
     537      REAL(wp), POINTER, DIMENSION(:,:) :: at_i 
    571538#endif 
    572539      LOGICAL :: llnightav        ! Logical for calculating night-time average 
    … …  
    582549      CALL wrk_alloc( jpi, jpj, zgphi1 ) 
    583550      CALL wrk_alloc( jpi, jpj, zgphi2 ) 
    584 #if ! defined key_lim2 && ! defined key_lim3 
    585       CALL wrk_alloc(jpi,jpj,frld)  
     551#if ! defined key_lim3 
     552      CALL wrk_alloc(jpi,jpj,at_i)  
    586553#endif 
     554      !----------------------------------------------------------------------- 
    587555 
    588556      IF(lwp) THEN 
    … …  
    595563 
    596564      !----------------------------------------------------------------------- 
    597       ! No LIM => frld == 0.0_wp 
    598       !----------------------------------------------------------------------- 
    599 #if ! defined key_lim2 && ! defined key_lim3 
    600       frld(:,:) = 0.0_wp 
     565      ! No LIM => at_i == 0.0_wp 
     566      !----------------------------------------------------------------------- 
     567#if ! defined key_lim3 
     568      at_i(:,:) = 0.0_wp 
    601569#endif 
    602570      !----------------------------------------------------------------------- 
    … …  
    665633               zsurfvar(:,:) = sshn(:,:) 
    666634               llnightav = .FALSE. 
    667 #if defined key_lim2 || defined key_lim3 
     635#if defined key_lim3 
    668636            CASE('sic') 
    669637               IF ( kstp == 0 ) THEN 
    … …  
    678646                  CYCLE 
    679647               ELSE 
    680                   zsurfvar(:,:) = 1._wp - frld(:,:) 
     648                  zsurfvar(:,:) = at_i(:,:) 
    681649               ENDIF 
    682650 
    … …  
    702670      CALL wrk_dealloc( jpi, jpj, zgphi1 ) 
    703671      CALL wrk_dealloc( jpi, jpj, zgphi2 ) 
    704 #if ! defined key_lim2 && ! defined key_lim3 
    705       CALL wrk_dealloc(jpi,jpj,frld) 
     672#if ! defined key_lim3 
     673      CALL wrk_dealloc(jpi,jpj,at_i) 
    706674#endif 
    707675 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r7646 r8586  
    116116   END TYPE WGT 
    117117 
    118    INTEGER,     PARAMETER             ::   tot_wgts = 10 
     118   INTEGER,     PARAMETER             ::   tot_wgts = 20 
    119119   TYPE( WGT ), DIMENSION(tot_wgts)   ::   ref_wgts     ! array of wgts 
    120120   INTEGER                            ::   nxt_wgt = 1  ! point to next available space in ref_wgts array 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r6416 r8586  
    99   !!            3.4  ! 2011-11  (C. Harris) CICE added as an option 
    1010   !!---------------------------------------------------------------------- 
    11 #if defined key_lim3 || defined key_lim2 || defined key_cice 
    12    !!---------------------------------------------------------------------- 
    13    !!   'key_lim2' or 'key_lim3' :             LIM-2 or LIM-3 sea-ice model 
     11#if defined key_lim3 || defined key_cice 
     12   !!---------------------------------------------------------------------- 
     13   !!   'key_lim3' or 'key_cice' :              LIM-3 or CICE sea-ice model 
    1414   !!---------------------------------------------------------------------- 
    1515   USE par_oce          ! ocean parameters 
    … …  
    1818   USE ice              ! LIM-3 parameters 
    1919# endif 
    20 # if defined key_lim2 
    21    USE par_ice_2        ! LIM-2 parameters 
    22    USE ice_2 
    23 # endif 
    2420# if defined key_cice 
    2521   USE ice_domain_size, only: ncat  
    … …  
    3127   PRIVATE 
    3228 
    33    PUBLIC sbc_ice_alloc ! called in iceini(_2).F90 
    34  
    35 # if defined  key_lim2 
    36    LOGICAL         , PUBLIC, PARAMETER ::   lk_lim2    = .TRUE.   !: LIM-2 ice model 
    37    LOGICAL         , PUBLIC, PARAMETER ::   lk_lim3    = .FALSE.  !: no LIM-3 
    38    LOGICAL         , PUBLIC, PARAMETER ::   lk_cice    = .FALSE.  !: no CICE  
    39 #  if defined key_lim2_vp 
    40    CHARACTER(len=1), PUBLIC, PARAMETER ::   cp_ice_msh = 'I'      !: VP : 'I'-grid ice-velocity (B-grid lower left corner) 
    41 #  else 
    42    CHARACTER(len=1), PUBLIC, PARAMETER ::   cp_ice_msh = 'C'      !: EVP: 'C'-grid ice-velocity 
    43 #  endif 
    44 # endif 
     29   PUBLIC   sbc_ice_alloc   ! called in sbcmod.F90 or sbcice_cice.F90 
     30 
    4531# if defined  key_lim3 
    46    LOGICAL         , PUBLIC, PARAMETER ::   lk_lim2    = .FALSE.  !: no LIM-2 
    4732   LOGICAL         , PUBLIC, PARAMETER ::   lk_lim3    = .TRUE.   !: LIM-3 ice model 
    4833   LOGICAL         , PUBLIC, PARAMETER ::   lk_cice    = .FALSE.  !: no CICE  
    … …  
    5035# endif 
    5136# if defined  key_cice 
    52    LOGICAL         , PUBLIC, PARAMETER ::   lk_lim2    = .FALSE.  !: no LIM-2 
    5337   LOGICAL         , PUBLIC, PARAMETER ::   lk_lim3    = .FALSE.  !: no LIM-3 
    5438   LOGICAL         , PUBLIC, PARAMETER ::   lk_cice    = .TRUE.   !: CICE ice model 
    … …  
    8367   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: enthalpy of precip over ice                 [J/m3] 
    8468   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_oce        !: evap - precip over ocean                 [kg/m2/s] 
    85 #endif 
    86 #if defined key_lim3 || defined key_lim2 
    8769   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wndm_ice       !: wind speed module at T-point                 [m/s] 
    8870#endif 
    … …  
    10688   INTEGER , PUBLIC, PARAMETER ::   jpl = ncat 
    10789   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   u_ice, v_ice          ! jpi, jpj 
    108 #endif 
    10990    
    110 #if defined key_lim2 || defined key_cice 
    11191   ! already defined in ice.F90 for LIM3 
    11292   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  a_i 
    113    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  ht_i, ht_s 
    114 #endif 
    115  
    116 #if defined key_cice 
     93   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  h_i, h_s 
     94 
    11795   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   tatm_ice       !: air temperature [K] 
    11896#endif 
    11997 
    12098   REAL(wp), PUBLIC, SAVE ::   cldf_ice = 0.81    !: cloud fraction over sea ice, summer CLIO value   [-] 
     99 
     100   !! arrays relating to embedding ice in the ocean 
     101   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_mass        !: mass of snow and ice at current  ice time step   [Kg/m2] 
     102   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_mass_b      !: mass of snow and ice at previous ice time step   [Kg/m2] 
     103   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_fmass       !: time evolution of mass of snow+ice               [Kg/m2/s] 
    121104 
    122105   !!---------------------------------------------------------------------- 
    … …  
    131114      !!                     ***  FUNCTION sbc_ice_alloc  *** 
    132115      !!---------------------------------------------------------------------- 
    133       INTEGER :: ierr(5) 
     116      INTEGER :: ierr(4) 
    134117      !!---------------------------------------------------------------------- 
    135118      ierr(:) = 0 
    136119 
    137 #if defined key_lim3 || defined key_lim2 
     120      ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) ) 
     121 
     122#if defined key_lim3 
    138123      ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) ,     & 
    139124         &      qla_ice (jpi,jpj,jpl) , dqla_ice(jpi,jpj,jpl) ,     & 
    … …  
    141126         &      utau_ice(jpi,jpj)     , vtau_ice(jpi,jpj)     , wndm_ice(jpi,jpj)     ,   & 
    142127         &      fr1_i0  (jpi,jpj)     , fr2_i0  (jpi,jpj)     ,     & 
    143 #if defined key_lim2 
    144          &      a_i(jpi,jpj,jpl)      ,                             & 
    145 #endif 
    146 #if defined key_lim3 
    147128         &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,   & 
    148129         &      qemp_ice(jpi,jpj)     , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) ,   & 
    149130         &      qns_oce (jpi,jpj)     , qsr_oce  (jpi,jpj)     , emp_oce (jpi,jpj)  ,   & 
    150 #endif 
    151          &      emp_ice(jpi,jpj)      ,  STAT= ierr(1) ) 
     131         &      emp_ice(jpi,jpj)      ,  STAT= ierr(2) ) 
    152132#endif 
    153133 
    … …  
    158138                ss_iov(jpi,jpj)       , fr_iu(jpi,jpj)        , fr_iv(jpi,jpj)        , & 
    159139                a_i(jpi,jpj,ncat)     , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , & 
    160                 STAT= ierr(1) ) 
     140                STAT= ierr(2) ) 
    161141      IF( ln_cpl )   ALLOCATE( u_ice(jpi,jpj)        , fr1_i0(jpi,jpj)       , tn_ice (jpi,jpj,1)    , & 
    162142         &                     v_ice(jpi,jpj)        , fr2_i0(jpi,jpj)       , alb_ice(jpi,jpj,1)    , & 
    163143         &                     emp_ice(jpi,jpj)      , qns_ice(jpi,jpj,1)    , dqns_ice(jpi,jpj,1)   , & 
    164          &                     STAT= ierr(2) ) 
    165        
    166 #endif 
    167          ! 
    168 #if defined key_cice || defined key_lim2 
    169       IF( ln_cpl )   ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(5) ) 
     144         &                     STAT= ierr(3) )       
     145      IF( ln_cpl )   ALLOCATE( h_i(jpi,jpj,jpl) , h_s(jpi,jpj,jpl) , STAT=ierr(4) ) 
    170146#endif 
    171147 
    … …  
    177153#else 
    178154   !!---------------------------------------------------------------------- 
    179    !!   Default option                      NO LIM 2.0 or 3.0 or CICE sea-ice model 
    180    !!---------------------------------------------------------------------- 
     155   !!   Default option                      NO LIM3 or CICE sea-ice model 
     156   !!---------------------------------------------------------------------- 
     157   USE lib_mpp          ! MPP library 
    181158   USE in_out_manager   ! I/O manager 
    182    LOGICAL         , PUBLIC, PARAMETER ::   lk_lim2    = .FALSE.  !: no LIM-2 ice model 
     159 
     160   IMPLICIT NONE 
     161   PRIVATE 
     162 
     163   PUBLIC sbc_ice_alloc 
     164 
    183165   LOGICAL         , PUBLIC, PARAMETER ::   lk_lim3    = .FALSE.  !: no LIM-3 ice model 
    184166   LOGICAL         , PUBLIC, PARAMETER ::   lk_cice    = .FALSE.  !: no CICE  ice model 
    185167   CHARACTER(len=1), PUBLIC, PARAMETER ::   cp_ice_msh = '-'      !: no grid ice-velocity 
    186    REAL            , PUBLIC, PARAMETER ::   cldf_ice = 0.81       !: cloud fraction over sea ice, summer CLIO value   [-] 
     168   REAL(wp)        , PUBLIC, PARAMETER ::   cldf_ice = 0.81       !: cloud fraction over sea ice, summer CLIO value   [-] 
    187169   INTEGER         , PUBLIC, PARAMETER ::   jpl = 1  
    188170   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   u_ice, v_ice,fr1_i0,fr2_i0          ! jpi, jpj 
    … …  
    191173   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_ice 
    192174   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qsr_ice 
    193    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ht_i, ht_s 
     175   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   h_i, h_s 
    194176   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   topmelt, botmelt 
     177   ! 
     178   !! arrays relating to embedding ice in the ocean. These arrays need to be declared  
     179   !! even if no ice model is required. In the no ice model or traditional levitating  
     180   !! ice cases they contain only zeros 
     181   !! --------------------- 
     182   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_mass        !: mass of snow and ice at current  ice time step   [Kg/m2] 
     183   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_mass_b      !: mass of snow and ice at previous ice time step   [Kg/m2] 
     184   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_fmass       !: time evolution of mass of snow+ice               [Kg/m2/s] 
     185   !!---------------------------------------------------------------------- 
     186CONTAINS 
     187 
     188   INTEGER FUNCTION sbc_ice_alloc() 
     189      !!---------------------------------------------------------------------- 
     190      !!                     ***  FUNCTION sbc_ice_alloc  *** 
     191      !!---------------------------------------------------------------------- 
     192      INTEGER :: ierr(1) 
     193      !!---------------------------------------------------------------------- 
     194      ierr(:) = 0 
     195      ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) ) 
     196      sbc_ice_alloc = MAXVAL( ierr ) 
     197      IF( lk_mpp            )   CALL mpp_sum ( sbc_ice_alloc ) 
     198      IF( sbc_ice_alloc > 0 )   CALL ctl_warn('sbc_ice_alloc: allocation of arrays failed') 
     199   END FUNCTION sbc_ice_alloc 
    195200#endif 
    196201 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90

    r7788 r8586  
    4747   LOGICAL , PUBLIC ::   ln_apr_dyn     !: Atmospheric pressure forcing used on dynamics (ocean & ice) 
    4848   INTEGER , PUBLIC ::   nn_ice         !: flag for ice in the surface boundary condition (=0/1/2/3) 
    49    INTEGER , PUBLIC ::   nn_ice_embd    !: flag for levitating/embedding sea-ice in the ocean 
    50    !                                             !: =0 levitating ice (no mass exchange, concentration/dilution effect) 
    51    !                                             !: =1 levitating ice with mass and salt exchange but no presure effect 
    52    !                                             !: =2 embedded sea-ice (full salt and mass exchanges and pressure) 
     49   LOGICAL , PUBLIC ::   ln_ice_embd    !: flag for levitating/embedding sea-ice in the ocean 
     50   !                                             !: =F levitating ice (no presure effect) with mass and salt exchanges 
     51   !                                             !: =T embedded sea-ice (pressure effect + mass and salt exchanges) 
    5352   INTEGER , PUBLIC ::   nn_components  !: flag for sbc module (including sea-ice) coupling mode (see component definition below)  
    54    INTEGER , PUBLIC ::   nn_limflx      !: LIM3 Multi-category heat flux formulation 
    55    !                                             !: =-1  Use of per-category fluxes 
    56    !                                             !: = 0  Average per-category fluxes 
    57    !                                             !: = 1  Average then redistribute per-category fluxes 
    58    !                                             !: = 2  Redistribute a single flux over categories 
    5953   INTEGER , PUBLIC ::   nn_fwb         !: FreshWater Budget:  
    6054   !                                             !:  = 0 unchecked  

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk.F90

    r7753 r8586  
    4040   USE lib_fortran    ! to use key_nosignedzero 
    4141#if defined key_lim3 
    42    USE ice     , ONLY :   u_ice, v_ice, jpl, pfrld, a_i_b, at_i_b 
    43    USE limthd_dh      ! for CALL lim_thd_snwblow 
    44 #elif defined key_lim2 
    45    USE ice_2   , ONLY :   u_ice, v_ice 
    46    USE par_ice_2      ! LIM-2 parameters 
     42   USE ice     , ONLY :   u_ice, v_ice, jpl, a_i_b, at_i_b 
     43   USE icethd_dh      ! for CALL ice_thd_snwblow 
    4744#endif 
    4845   USE sbcblk_algo_ncar     ! => turb_ncar     : NCAR - CORE (Large & Yeager, 2009)  
    … …  
    5451   USE in_out_manager ! I/O manager 
    5552   USE lib_mpp        ! distribued memory computing library 
    56    USE wrk_nemo       ! work arrays 
    5753   USE timing         ! Timing 
    5854   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    … …  
    6460   PUBLIC   sbc_blk_init  ! called in sbcmod 
    6561   PUBLIC   sbc_blk       ! called in sbcmod 
    66 #if defined key_lim2 || defined key_lim3 
    67    PUBLIC   blk_ice_tau   ! routine called in sbc_ice_lim module 
    68    PUBLIC   blk_ice_flx   ! routine called in sbc_ice_lim module 
     62#if defined key_lim3 
     63   PUBLIC   blk_ice_tau   ! routine called in icestp module 
     64   PUBLIC   blk_ice_flx   ! routine called in icestp module 
    6965#endif 
    7066 
    … …  
    111107   REAL(wp) ::   rn_zqt         ! z(q,t) : height of humidity and temperature measurements 
    112108   REAL(wp) ::   rn_zu          ! z(u)   : height of wind measurements 
     109!!gm ref namelist initialize it so remove the setting to false below 
    113110   LOGICAL  ::   ln_Cd_L12 = .FALSE. !  Modify the drag ice-atm and oce-atm depending on ice concentration (from Lupkes et al. JGR2012) 
    114111   ! 
    … …  
    360357      INTEGER  ::   ji, jj               ! dummy loop indices 
    361358      REAL(wp) ::   zztmp                ! local variable 
    362       REAL(wp), DIMENSION(:,:), POINTER ::   zwnd_i, zwnd_j    ! wind speed components at T-point 
    363       REAL(wp), DIMENSION(:,:), POINTER ::   zsq               ! specific humidity at pst 
    364       REAL(wp), DIMENSION(:,:), POINTER ::   zqlw, zqsb        ! long wave and sensible heat fluxes 
    365       REAL(wp), DIMENSION(:,:), POINTER ::   zqla, zevap       ! latent heat fluxes and evaporation 
    366       REAL(wp), DIMENSION(:,:), POINTER ::   Cd                ! transfer coefficient for momentum      (tau) 
    367       REAL(wp), DIMENSION(:,:), POINTER ::   Ch                ! transfer coefficient for sensible heat (Q_sens) 
    368       REAL(wp), DIMENSION(:,:), POINTER ::   Ce                ! tansfert coefficient for evaporation   (Q_lat) 
    369       REAL(wp), DIMENSION(:,:), POINTER ::   zst               ! surface temperature in Kelvin 
    370       REAL(wp), DIMENSION(:,:), POINTER ::   zt_zu             ! air temperature at wind speed height 
    371       REAL(wp), DIMENSION(:,:), POINTER ::   zq_zu             ! air spec. hum.  at wind speed height 
    372       REAL(wp), DIMENSION(:,:), POINTER ::   zU_zu             ! bulk wind speed at height zu  [m/s] 
    373       REAL(wp), DIMENSION(:,:), POINTER ::   ztpot             ! potential temperature of air at z=rn_zqt [K] 
    374       REAL(wp), DIMENSION(:,:), POINTER ::   zrhoa             ! density of air   [kg/m^3] 
    375       !!--------------------------------------------------------------------- 
    376       ! 
    377       IF( nn_timing == 1 )  CALL timing_start('blk_oce') 
    378       ! 
    379       CALL wrk_alloc( jpi,jpj,   zwnd_i, zwnd_j, zsq, zqlw, zqsb, zqla, zevap ) 
    380       CALL wrk_alloc( jpi,jpj,   Cd, Ch, Ce, zst, zt_zu, zq_zu ) 
    381       CALL wrk_alloc( jpi,jpj,   zU_zu, ztpot, zrhoa ) 
    382       ! 
    383  
     359      REAL(wp), DIMENSION(jpi,jpj) ::   zwnd_i, zwnd_j    ! wind speed components at T-point 
     360      REAL(wp), DIMENSION(jpi,jpj) ::   zsq               ! specific humidity at pst 
     361      REAL(wp), DIMENSION(jpi,jpj) ::   zqlw, zqsb        ! long wave and sensible heat fluxes 
     362      REAL(wp), DIMENSION(jpi,jpj) ::   zqla, zevap       ! latent heat fluxes and evaporation 
     363      REAL(wp), DIMENSION(jpi,jpj) ::   zCd               ! transfer coefficient for momentum      (tau) 
     364      REAL(wp), DIMENSION(jpi,jpj) ::   zCh               ! transfer coefficient for sensible heat (Q_sens) 
     365      REAL(wp), DIMENSION(jpi,jpj) ::   zCe               ! tansfert coefficient for evaporation   (Q_lat) 
     366      REAL(wp), DIMENSION(jpi,jpj) ::   zst               ! surface temperature in Kelvin 
     367      REAL(wp), DIMENSION(jpi,jpj) ::   zt_zu             ! air temperature at wind speed height 
     368      REAL(wp), DIMENSION(jpi,jpj) ::   zq_zu             ! air spec. hum.  at wind speed height 
     369      REAL(wp), DIMENSION(jpi,jpj) ::   zU_zu             ! bulk wind speed at height zu  [m/s] 
     370      REAL(wp), DIMENSION(jpi,jpj) ::   ztpot             ! potential temperature of air at z=rn_zqt [K] 
     371      REAL(wp), DIMENSION(jpi,jpj) ::   zrhoa             ! density of air   [kg/m^3] 
     372      !!--------------------------------------------------------------------- 
     373      ! 
     374      IF( ln_timing )   CALL timing_start('blk_oce') 
     375      ! 
    384376      ! local scalars ( place there for vector optimisation purposes) 
    385377      zst(:,:) = pst(:,:) + rt0      ! convert SST from Celcius to Kelvin (and set minimum value far above 0 K) 
    … …  
    443435      ! 
    444436      CASE( np_NCAR      )   ;   CALL turb_ncar    ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! NCAR-COREv2 
    445          &                                               Cd, Ch, Ce, zt_zu, zq_zu, zU_zu ) 
     437         &                                              zCd, zCh, zCe, zt_zu, zq_zu, zU_zu ) 
    446438      CASE( np_COARE_3p0 )   ;   CALL turb_coare   ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! COARE v3.0 
    447          &                                               Cd, Ch, Ce, zt_zu, zq_zu, zU_zu ) 
     439         &                                              zCd, zCh, zCe, zt_zu, zq_zu, zU_zu ) 
    448440      CASE( np_COARE_3p5 )   ;   CALL turb_coare3p5( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! COARE v3.5 
    449          &                                               Cd, Ch, Ce, zt_zu, zq_zu, zU_zu ) 
     441         &                                              zCd, zCh, zCe, zt_zu, zq_zu, zU_zu ) 
    450442      CASE( np_ECMWF     )   ;   CALL turb_ecmwf   ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! ECMWF 
    451          &                                               Cd, Ch, Ce, zt_zu, zq_zu, zU_zu ) 
     443         &                                              zCd, zCh, zCe, zt_zu, zq_zu, zU_zu ) 
    452444      CASE DEFAULT 
    453445         CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk formula selected' ) 
    … …  
    461453      END IF 
    462454 
    463       Cd_oce(:,:) = Cd(:,:)  ! record value of pure ocean-atm. drag (clem) 
     455      Cd_oce(:,:) = zCd(:,:)     ! record value of pure ocean-atm. drag (clem) 
    464456 
    465457      DO jj = 1, jpj             ! tau module, i and j component 
    466458         DO ji = 1, jpi 
    467             zztmp = zrhoa(ji,jj)  * zU_zu(ji,jj) * Cd(ji,jj)   ! using bulk wind speed 
     459            zztmp = zrhoa(ji,jj)  * zU_zu(ji,jj) * zCd(ji,jj)   ! using bulk wind speed 
    468460            taum  (ji,jj) = zztmp * wndm  (ji,jj) 
    469461            zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) 
    … …  
    500492      IF( ABS( rn_zu - rn_zqt) < 0.01_wp ) THEN 
    501493         !! q_air and t_air are given at 10m (wind reference height) 
    502          zevap(:,:) = rn_efac*MAX( 0._wp,             zqla(:,:)*Ce(:,:)*(zsq(:,:) - sf(jp_humi)%fnow(:,:,1)) ) ! Evaporation, using bulk wind speed 
    503          zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch(:,:)*(zst(:,:) - ztpot(:,:)             )   ! Sensible Heat, using bulk wind speed 
     494         zevap(:,:) = rn_efac*MAX( 0._wp,             zqla(:,:)*zCe(:,:)*(zsq(:,:) - sf(jp_humi)%fnow(:,:,1)) )  ! Evaporation, using bulk wind speed 
     495         zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*zCh(:,:)*(zst(:,:) - ztpot(:,:)               )   ! Sensible Heat, using bulk wind speed 
    504496      ELSE 
    505497         !! q_air and t_air are not given at 10m (wind reference height) 
    506498         ! Values of temp. and hum. adjusted to height of wind during bulk algorithm iteration must be used!!! 
    507          zevap(:,:) = rn_efac*MAX( 0._wp,             zqla(:,:)*Ce(:,:)*(zsq(:,:) - zq_zu(:,:) ) ) ! Evaporation ! using bulk wind speed 
    508          zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch(:,:)*(zst(:,:) - zt_zu(:,:) )   ! Sensible Heat ! using bulk wind speed 
     499         zevap(:,:) = rn_efac*MAX( 0._wp,             zqla(:,:)*zCe(:,:)*(zsq(:,:) - zq_zu(:,:) ) ) ! Evaporation ! using bulk wind speed 
     500         zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*zCh(:,:)*(zst(:,:) - zt_zu(:,:) )   ! Sensible Heat ! using bulk wind speed 
    509501      ENDIF 
    510502 
    … …  
    513505 
    514506      IF(ln_ctl) THEN 
    515          CALL prt_ctl( tab2d_1=zqla  , clinfo1=' blk_oce: zqla   : ', tab2d_2=Ce , clinfo2=' Ce  : ' ) 
    516          CALL prt_ctl( tab2d_1=zqsb  , clinfo1=' blk_oce: zqsb   : ', tab2d_2=Ch , clinfo2=' Ch  : ' ) 
     507         CALL prt_ctl( tab2d_1=zqla  , clinfo1=' blk_oce: zqla   : ', tab2d_2=zCe , clinfo2=' Ce  : ' ) 
     508         CALL prt_ctl( tab2d_1=zqsb  , clinfo1=' blk_oce: zqsb   : ', tab2d_2=zCh , clinfo2=' Ch  : ' ) 
    517509         CALL prt_ctl( tab2d_1=zqlw  , clinfo1=' blk_oce: zqlw   : ', tab2d_2=qsr, clinfo2=' qsr : ' ) 
    518510         CALL prt_ctl( tab2d_1=zsq   , clinfo1=' blk_oce: zsq    : ', tab2d_2=zst, clinfo2=' zst : ' ) 
    … …  
    565557      ENDIF 
    566558      ! 
    567       CALL wrk_dealloc( jpi,jpj,   zwnd_i, zwnd_j, zsq, zqlw, zqsb, zqla, zevap ) 
    568       CALL wrk_dealloc( jpi,jpj,   Cd, Ch, Ce, zst, zt_zu, zq_zu ) 
    569       CALL wrk_dealloc( jpi,jpj,   zU_zu, ztpot, zrhoa ) 
    570       ! 
    571       IF( nn_timing == 1 )  CALL timing_stop('blk_oce') 
     559      IF( ln_timing )   CALL timing_stop('blk_oce') 
    572560      ! 
    573561   END SUBROUTINE blk_oce 
    574562 
    575 #if defined key_lim2 || defined key_lim3 
     563#if defined key_lim3 
    576564 
    577565   SUBROUTINE blk_ice_tau 
    … …  
    586574      !!--------------------------------------------------------------------- 
    587575      INTEGER  ::   ji, jj    ! dummy loop indices 
    588       ! 
    589       REAL(wp), DIMENSION(:,:)  , POINTER :: zrhoa 
    590       ! 
    591       REAL(wp) ::   zwnorm_f, zwndi_f , zwndj_f               ! relative wind module and components at F-point 
    592       REAL(wp) ::             zwndi_t , zwndj_t               ! relative wind components at T-point 
    593       REAL(wp), DIMENSION(:,:), POINTER ::   Cd               ! transfer coefficient for momentum      (tau) 
    594       !!--------------------------------------------------------------------- 
    595       ! 
    596       IF( nn_timing == 1 )  CALL timing_start('blk_ice_tau') 
    597       ! 
    598       CALL wrk_alloc( jpi,jpj, zrhoa ) 
    599       CALL wrk_alloc( jpi,jpj, Cd ) 
    600  
    601       Cd(:,:) = Cd_ice 
    602  
    603       ! Make ice-atm. drag dependent on ice concentration (see Lupkes et al. 2012) (clem) 
    604 #if defined key_lim3 
     576      REAL(wp) ::   zwndi_f , zwndj_f, zwnorm_f      ! relative wind module and components at F-point 
     577      REAL(wp) ::   zwndi_t , zwndj_t                ! relative wind components at T-point 
     578      REAL(wp), DIMENSION(jpi,jpj) ::   zCd, zrhoa   ! transfer coefficient for momentum      (tau) 
     579      !!--------------------------------------------------------------------- 
     580      ! 
     581      IF( ln_timing )   CALL timing_start('blk_ice_tau') 
     582      ! 
    605583      IF( ln_Cd_L12 ) THEN 
    606          CALL Cdn10_Lupkes2012( Cd ) ! calculate new drag from Lupkes(2012) equations 
    607       ENDIF 
    608 #endif 
     584         CALL Cdn10_Lupkes2012( zCd )  ! air-ice drag = F(ice concentration) (see Lupkes et al., 2012) 
     585      ELSE 
     586         zCd(:,:) = Cd_ice             ! constant air-ice drag 
     587      ENDIF 
    609588 
    610589      ! local scalars ( place there for vector optimisation purposes) 
    … …  
    632611               zwndj_f = 0.25 * (  sf(jp_wndj)%fnow(ji-1,jj  ,1) + sf(jp_wndj)%fnow(ji  ,jj  ,1)   & 
    633612                  &              + sf(jp_wndj)%fnow(ji-1,jj-1,1) + sf(jp_wndj)%fnow(ji  ,jj-1,1)  ) - rn_vfac * v_ice(ji,jj) 
    634                zwnorm_f = zrhoa(ji,jj) * Cd(ji,jj) * SQRT( zwndi_f * zwndi_f + zwndj_f * zwndj_f ) 
     613               zwnorm_f = zrhoa(ji,jj) * zCd(ji,jj) * SQRT( zwndi_f * zwndi_f + zwndj_f * zwndj_f ) 
    635614               ! ... ice stress at I-point 
    636615               utau_ice(ji,jj) = zwnorm_f * zwndi_f 
    … …  
    658637         DO jj = 2, jpjm1 
    659638            DO ji = fs_2, fs_jpim1   ! vect. opt. 
    660                utau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * Cd(ji,jj) * ( wndm_ice(ji+1,jj  ) + wndm_ice(ji,jj) )                          & 
     639               utau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * zCd(ji,jj) * ( wndm_ice(ji+1,jj  ) + wndm_ice(ji,jj) )                          & 
    661640                  &          * ( 0.5 * (sf(jp_wndi)%fnow(ji+1,jj,1) + sf(jp_wndi)%fnow(ji,jj,1) ) - rn_vfac * u_ice(ji,jj) ) 
    662                vtau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * Cd(ji,jj) * ( wndm_ice(ji,jj+1  ) + wndm_ice(ji,jj) )                          & 
     641               vtau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * zCd(ji,jj) * ( wndm_ice(ji,jj+1  ) + wndm_ice(ji,jj) )                          & 
    663642                  &          * ( 0.5 * (sf(jp_wndj)%fnow(ji,jj+1,1) + sf(jp_wndj)%fnow(ji,jj,1) ) - rn_vfac * v_ice(ji,jj) ) 
    664643            END DO 
    … …  
    669648         ! 
    670649      END SELECT 
    671  
     650      ! 
    672651      IF(ln_ctl) THEN 
    673652         CALL prt_ctl(tab2d_1=utau_ice  , clinfo1=' blk_ice: utau_ice : ', tab2d_2=vtau_ice  , clinfo2=' vtau_ice : ') 
    674653         CALL prt_ctl(tab2d_1=wndm_ice  , clinfo1=' blk_ice: wndm_ice : ') 
    675654      ENDIF 
    676  
    677       IF( nn_timing == 1 )  CALL timing_stop('blk_ice_tau') 
    678  
     655      ! 
     656      IF( ln_timing )   CALL timing_stop('blk_ice_tau') 
     657      ! 
    679658   END SUBROUTINE blk_ice_tau 
    680659 
    … …  
    699678      REAL(wp) ::   zcoef_dqlw, zcoef_dqla   !   -      - 
    700679      REAL(wp) ::   zztmp, z1_lsub           !   -      - 
    701       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw         ! long wave heat flux over ice 
    702       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qsb         ! sensible  heat flux over ice 
    703       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqlw        ! long wave heat sensitivity over ice 
    704       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqsb        ! sensible  heat sensitivity over ice 
    705       REAL(wp), DIMENSION(:,:)  , POINTER ::   zevap, zsnw   ! evaporation and snw distribution after wind blowing (LIM3) 
    706       REAL(wp), DIMENSION(:,:)  , POINTER ::   zrhoa 
    707       REAL(wp), DIMENSION(:,:)  , POINTER ::   Cd            ! transfer coefficient for momentum      (tau) 
    708       !!--------------------------------------------------------------------- 
    709       ! 
    710       IF( nn_timing == 1 )  CALL timing_start('blk_ice_flx') 
    711       ! 
    712       CALL wrk_alloc( jpi,jpj,jpl,   z_qlw, z_qsb, z_dqlw, z_dqsb ) 
    713       CALL wrk_alloc( jpi,jpj,       zrhoa) 
    714       CALL wrk_alloc( jpi,jpj, Cd ) 
    715  
    716       Cd(:,:) = Cd_ice 
    717  
    718       ! Make ice-atm. drag dependent on ice concentration (see Lupkes et al.  2012) (clem) 
    719 #if defined key_lim3 
     680      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z_qlw         ! long wave heat flux over ice 
     681      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z_qsb         ! sensible  heat flux over ice 
     682      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z_dqlw        ! long wave heat sensitivity over ice 
     683      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z_dqsb        ! sensible  heat sensitivity over ice 
     684      REAL(wp), DIMENSION(jpi,jpj)     ::   zevap, zsnw   ! evaporation and snw distribution after wind blowing (LIM3) 
     685      REAL(wp), DIMENSION(jpi,jpj)     ::   zrhoa 
     686      REAL(wp), DIMENSION(jpi,jpj)     ::   zCd            ! transfer coefficient for momentum      (tau) 
     687      !!--------------------------------------------------------------------- 
     688      ! 
     689      IF( ln_timing )   CALL timing_start('blk_ice_flx') 
     690      ! 
    720691      IF( ln_Cd_L12 ) THEN 
    721          CALL Cdn10_Lupkes2012( Cd ) ! calculate new drag from Lupkes(2012) equations 
    722       ENDIF 
    723 #endif 
     692         CALL Cdn10_Lupkes2012( zCd )  ! air-ice drag = F(ice concentration) (see Lupkes et al., 2012) 
     693      ELSE 
     694         zCd(:,:) = Cd_ice             ! constant air-ice drag 
     695      ENDIF 
    724696 
    725697      ! 
    … …  
    754726               ! ... turbulent heat fluxes 
    755727               ! Sensible Heat 
    756                z_qsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Cd(ji,jj) * wndm_ice(ji,jj) * ( ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1) ) 
     728               z_qsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * zCd(ji,jj) * wndm_ice(ji,jj) * ( ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1) ) 
    757729               ! Latent Heat 
    758                qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, zrhoa(ji,jj) * Ls  * Cd(ji,jj) * wndm_ice(ji,jj)   & 
     730               qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, zrhoa(ji,jj) * Ls  * zCd(ji,jj) * wndm_ice(ji,jj)   & 
    759731                  &                         * (  11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / zrhoa(ji,jj) - sf(jp_humi)%fnow(ji,jj,1)  ) ) 
    760732               ! Latent heat sensitivity for ice (Dqla/Dt) 
    761733               IF( qla_ice(ji,jj,jl) > 0._wp ) THEN 
    762                   dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * Cd(ji,jj) * wndm_ice(ji,jj) / ( zst2 ) * EXP( -5897.8 / ptsu(ji,jj,jl) ) 
     734                  dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * zCd(ji,jj) * wndm_ice(ji,jj) / ( zst2 ) * EXP( -5897.8 / ptsu(ji,jj,jl) ) 
    763735               ELSE 
    764736                  dqla_ice(ji,jj,jl) = 0._wp 
    … …  
    766738 
    767739               ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice) 
    768                z_dqsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Cd(ji,jj) * wndm_ice(ji,jj) 
     740               z_dqsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * zCd(ji,jj) * wndm_ice(ji,jj) 
    769741 
    770742               ! ----------------------------! 
    … …  
    786758      CALL iom_put( 'precip' , tprecip * 86400. )                  ! Total precipitation 
    787759 
    788 #if defined  key_lim3 
    789       CALL wrk_alloc( jpi,jpj,   zevap, zsnw ) 
    790  
    791760      ! --- evaporation --- ! 
    792761      z1_lsub = 1._wp / Lsub 
    … …  
    797766      ! --- evaporation minus precipitation --- ! 
    798767      zsnw(:,:) = 0._wp 
    799       CALL lim_thd_snwblow( pfrld, zsnw )  ! snow distribution over ice after wind blowing 
    800       emp_oce(:,:) = pfrld(:,:) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) 
     768      CALL ice_thd_snwblow( (1.-at_i_b(:,:)), zsnw )  ! snow distribution over ice after wind blowing 
     769      emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) 
    801770      emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw 
    802771      emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) 
    803772 
    804773      ! --- heat flux associated with emp --- ! 
    805       qemp_oce(:,:) = - pfrld(:,:) * zevap(:,:) * sst_m(:,:) * rcp                               & ! evap at sst 
     774      qemp_oce(:,:) = - ( 1._wp - at_i_b(:,:) ) * zevap(:,:) * sst_m(:,:) * rcp                  & ! evap at sst 
    806775         &          + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp  & ! liquid precip at Tair 
    807776         &          +   sprecip(:,:) * ( 1._wp - zsnw ) *                                        & ! solid precip at min(Tair,Tsnow) 
    … …  
    811780 
    812781      ! --- total solar and non solar fluxes --- ! 
    813       qns_tot(:,:) = pfrld(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) 
    814       qsr_tot(:,:) = pfrld(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) 
     782      qns_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 )  & 
     783         &           + qemp_ice(:,:) + qemp_oce(:,:) 
     784      qsr_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) 
    815785 
    816786      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    … …  
    820790      DO jl = 1, jpl 
    821791         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) ) 
    822                                    ! But we do not have Tice => consider it at 0degC => evap=0  
     792         !                         ! But we do not have Tice => consider it at 0degC => evap=0  
    823793      END DO 
    824  
    825       CALL wrk_dealloc( jpi,jpj,   zevap, zsnw ) 
    826 #endif 
    827794 
    828795      !-------------------------------------------------------------------- 
    … …  
    833800      fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 
    834801      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    835       ! 
    836802      ! 
    837803      IF(ln_ctl) THEN 
    … …  
    843809         CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice: tprecip  : ', tab2d_2=sprecip , clinfo2=' sprecip  : ') 
    844810      ENDIF 
    845  
    846       CALL wrk_dealloc( jpi,jpj,jpl,   z_qlw, z_qsb, z_dqlw, z_dqsb ) 
    847       CALL wrk_dealloc( jpi,jpj,       zrhoa ) 
    848       CALL wrk_dealloc( jpi,jpj, Cd ) 
    849       ! 
    850       IF( nn_timing == 1 )  CALL timing_stop('blk_ice_flx') 
    851  
     811      ! 
     812      IF( ln_timing )   CALL timing_stop('blk_ice_flx') 
     813      ! 
    852814   END SUBROUTINE blk_ice_flx 
    853815    
    … …  
    971933   END FUNCTION L_vap 
    972934 
    973  
    974935#if defined key_lim3 
    975    SUBROUTINE Cdn10_Lupkes2012( Cd ) 
     936 
     937   SUBROUTINE Cdn10_Lupkes2012( pCd ) 
    976938      !!---------------------------------------------------------------------- 
    977939      !!                      ***  ROUTINE  Cdn10_Lupkes2012  *** 
    … …  
    1003965      !! 
    1004966      !!---------------------------------------------------------------------- 
    1005       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   Cd 
     967      REAL(wp), DIMENSION(:,:), INTENT(  out) ::   pCd   ! air-ice drag coefficient 
    1006968      REAL(wp), PARAMETER ::   zCe   = 2.23e-03_wp 
    1007969      REAL(wp), PARAMETER ::   znu   = 1._wp 
    … …  
    1011973      !!---------------------------------------------------------------------- 
    1012974      zcoef = znu + 1._wp / ( 10._wp * zbeta ) 
    1013  
     975      ! 
    1014976      ! generic drag over a cell partly covered by ice 
    1015       !!Cd(:,:) = Cd_oce(:,:) * ( 1._wp - at_i_b(:,:) ) +  &                        ! pure ocean drag 
    1016       !!   &      Cd_ice      *           at_i_b(:,:)   +  &                        ! pure ice drag 
    1017       !!   &      zCe         * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**zmu   ! change due to sea-ice morphology 
     977      !!pCd(:,:) = Cd_oce(:,:) * ( 1._wp - at_i_b(:,:) ) +  &                        ! pure ocean drag 
     978      !!   &       Cd_ice      *           at_i_b(:,:)   +  &                        ! pure ice drag 
     979      !!   &       zCe         * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**zmu   ! change due to sea-ice morphology 
    1018980 
    1019981      ! ice-atm drag 
    1020       Cd(:,:) = Cd_ice +  &                                                         ! pure ice drag 
    1021          &      zCe    * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**(zmu-1._wp)  ! change due to sea-ice morphology 
    1022        
     982      pCd(:,:) = Cd_ice +  &                                                         ! pure ice drag 
     983         &       zCe    * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**(zmu-1._wp)  ! change due to sea-ice morphology 
     984      ! 
    1023985   END SUBROUTINE Cdn10_Lupkes2012 
    1024986#endif 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r8215 r8586  
    3030   USE ice            ! ice variables 
    3131#endif 
    32 #if defined key_lim2 
    33    USE par_ice_2      ! ice parameters 
    34    USE ice_2          ! ice variables 
    35 #endif 
    3632   USE cpl_oasis3     ! OASIS3 coupling 
    3733   USE geo2ocean      !  
    3834   USE oce   , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev 
    39    USE albedo         !  
     35   USE albedooce      !  
    4036   USE eosbn2         !  
    4137   USE sbcrnf, ONLY : l_rnfcpl 
    … …  
    4541#endif 
    4642#if defined key_lim3 
    47    USE limthd_dh      ! for CALL lim_thd_snwblow 
     43   USE icethd_dh      ! for CALL ice_thd_snwblow 
    4844#endif 
    4945   ! 
    … …  
    5955 
    6056   PUBLIC   sbc_cpl_init      ! routine called by sbcmod.F90 
    61    PUBLIC   sbc_cpl_rcv       ! routine called by sbc_ice_lim(_2).F90 
     57   PUBLIC   sbc_cpl_rcv       ! routine called by icestp.F90 
    6258   PUBLIC   sbc_cpl_snd       ! routine called by step.F90 
    63    PUBLIC   sbc_cpl_ice_tau   ! routine called by sbc_ice_lim(_2).F90 
    64    PUBLIC   sbc_cpl_ice_flx   ! routine called by sbc_ice_lim(_2).F90 
     59   PUBLIC   sbc_cpl_ice_tau   ! routine called by icestp.F90 
     60   PUBLIC   sbc_cpl_ice_flx   ! routine called by icestp.F90 
    6561   PUBLIC   sbc_cpl_alloc     ! routine called in sbcice_cice.F90 
    6662 
    … …  
    208204      ALLOCATE( albedo_oce_mix(jpi,jpj), nrcvinfo(jprcv),  STAT=ierr(1) ) 
    209205       
    210 #if ! defined key_lim3 && ! defined key_lim2 && ! defined key_cice 
     206#if ! defined key_lim3 && ! defined key_cice 
    211207      ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) )  ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) 
    212208#endif 
    … …  
    505501      ! 
    506502      ! non solar sensitivity mandatory for LIM ice model 
    507       IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4 .AND. nn_components /= jp_iam_sas ) & 
     503      IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 3 .AND. nn_components /= jp_iam_sas ) & 
    508504         CALL ctl_stop( 'sbc_cpl_init: sn_rcv_dqnsdt%cldes must be coupled in namsbc_cpl namelist' ) 
    509505      ! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique 
    … …  
    11471143      ! 
    11481144      IF( ln_sdw ) THEN  ! Stokes Drift correction activated 
    1149       !                                                      ! ========================= !  
    1150       !                                                      !       Stokes drift u      ! 
    1151       !                                                      ! ========================= !  
    1152          IF( srcv(jpr_sdrftx)%laction ) ut0sd(:,:) = frcv(jpr_sdrftx)%z3(:,:,1) 
    1153       ! 
    1154       !                                                      ! ========================= !  
    1155       !                                                      !       Stokes drift v      ! 
    1156       !                                                      ! ========================= !  
    1157          IF( srcv(jpr_sdrfty)%laction ) vt0sd(:,:) = frcv(jpr_sdrfty)%z3(:,:,1) 
    1158       ! 
    1159       !                                                      ! ========================= !  
    1160       !                                                      !      Wave mean period     ! 
    1161       !                                                      ! ========================= !  
    1162          IF( srcv(jpr_wper)%laction )   wmp(:,:) = frcv(jpr_wper)%z3(:,:,1) 
    1163       ! 
    1164       !                                                      ! ========================= !  
    1165       !                                                      !  Significant wave height  ! 
    1166       !                                                      ! ========================= !  
    1167          IF( srcv(jpr_hsig)%laction )   hsw(:,:) = frcv(jpr_hsig)%z3(:,:,1) 
    1168       ! 
    1169       !                                                      ! ========================= !  
    1170       !                                                      !    surface wave mixing    ! 
    1171       !                                                      ! ========================= !  
     1145         !                                                   ! ========================= !  
     1146         !                                                   !       Stokes drift u      ! 
     1147         !                                                   ! ========================= !  
     1148         IF( srcv(jpr_sdrftx)%laction )   ut0sd(:,:) = frcv(jpr_sdrftx)%z3(:,:,1) 
     1149         ! 
     1150         !                                                   ! ========================= !  
     1151         !                                                   !       Stokes drift v      ! 
     1152         !                                                   ! ========================= !  
     1153         IF( srcv(jpr_sdrfty)%laction )   vt0sd(:,:) = frcv(jpr_sdrfty)%z3(:,:,1) 
     1154         ! 
     1155         !                                                   ! ========================= !  
     1156         !                                                   !      Wave mean period     ! 
     1157         !                                                   ! ========================= !  
     1158         IF( srcv(jpr_wper)%laction   )   wmp(:,:) = frcv(jpr_wper)%z3(:,:,1) 
     1159         ! 
     1160         !                                                   ! ========================= !  
     1161         !                                                   !  Significant wave height  ! 
     1162         !                                                   ! ========================= !  
     1163         IF( srcv(jpr_hsig)%laction   )   hsw(:,:) = frcv(jpr_hsig)%z3(:,:,1) 
     1164         ! 
     1165         !                                                   ! ========================= !  
     1166         !                                                   !    surface wave mixing    ! 
     1167         !                                                   ! ========================= !  
    11721168         IF( srcv(jpr_wnum)%laction .AND. ln_zdfswm )   wnum(:,:) = frcv(jpr_wnum)%z3(:,:,1) 
    11731169 
    … …  
    11811177      !                                                      ! Stress adsorbed by waves  ! 
    11821178      !                                                      ! ========================= !  
    1183       IF( srcv(jpr_wstrf)%laction .AND. ln_tauoc ) tauoc_wave(:,:) = frcv(jpr_wstrf)%z3(:,:,1) 
     1179      IF( srcv(jpr_wstrf)%laction .AND. ln_tauoc )   tauoc_wave(:,:) = frcv(jpr_wstrf)%z3(:,:,1) 
    11841180 
    11851181      !                                                      ! ========================= !  
    11861182      !                                                      !   Wave drag coefficient   ! 
    11871183      !                                                      ! ========================= !  
    1188       IF( srcv(jpr_wdrag)%laction .AND. ln_cdgw ) cdn_wave(:,:) = frcv(jpr_wdrag)%z3(:,:,1) 
     1184      IF( srcv(jpr_wdrag)%laction .AND. ln_cdgw )   cdn_wave(:,:) = frcv(jpr_wdrag)%z3(:,:,1) 
    11891185 
    11901186      !  Fields received by SAS when OASIS coupling 
    … …  
    12191215      IF( srcv(jpr_ocx1)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
    12201216         ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 
    1221          ub (:,:,1) = ssu_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1217         ub (:,:,1) = ssu_m(:,:)                             ! will be used in icestp in the call of lim_sbc_tau 
    12221218         un (:,:,1) = ssu_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    12231219         CALL iom_put( 'ssu_m', ssu_m ) 
    … …  
    12251221      IF( srcv(jpr_ocy1)%laction ) THEN 
    12261222         ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 
    1227          vb (:,:,1) = ssv_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1223         vb (:,:,1) = ssv_m(:,:)                             ! will be used in icestp in the call of lim_sbc_tau 
    12281224         vn (:,:,1) = ssv_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    12291225         CALL iom_put( 'ssv_m', ssv_m ) 
    … …  
    15291525    
    15301526 
    1531    SUBROUTINE sbc_cpl_ice_flx( p_frld, palbi, psst, pist ) 
     1527   SUBROUTINE sbc_cpl_ice_flx( picefr, palbi, psst, pist ) 
    15321528      !!---------------------------------------------------------------------- 
    15331529      !!             ***  ROUTINE sbc_cpl_ice_flx  *** 
    … …  
    15621558      !! 
    15631559      !! ** Details 
    1564       !!             qns_tot = pfrld * qns_oce + ( 1 - pfrld ) * qns_ice   => provided 
     1560      !!             qns_tot = (1-a) * qns_oce + a * qns_ice               => provided 
    15651561      !!                     + qemp_oce + qemp_ice                         => recalculated and added up to qns 
    15661562      !! 
    1567       !!             qsr_tot = pfrld * qsr_oce + ( 1 - pfrld ) * qsr_ice   => provided 
    1568       !! 
    1569       !!             emp_tot = emp_oce + emp_ice                           => calving is provided and added to emp_tot (and emp_oce) 
    1570       !!                                                                      river runoff (rnf) is provided but not included here 
    1571       !! 
     1563      !!             qsr_tot = (1-a) * qsr_oce + a * qsr_ice               => provided 
     1564      !! 
     1565      !!             emp_tot = emp_oce + emp_ice                           => calving is provided and added to emp_tot (and emp_oce). 
     1566      !!                                                                      runoff (which includes rivers+icebergs) and iceshelf 
     1567      !!                                                                      are provided but not included in emp here. Only runoff will 
     1568      !!                                                                      be included in emp in other parts of NEMO code 
    15721569      !! ** Action  :   update at each nf_ice time step: 
    15731570      !!                   qns_tot, qsr_tot  non-solar and solar total heat fluxes 
    … …  
    15781575      !!                   sprecip           solid precipitation over the ocean   
    15791576      !!---------------------------------------------------------------------- 
    1580       REAL(wp), INTENT(in   ), DIMENSION(:,:)   ::   p_frld     ! lead fraction                [0 to 1] 
     1577      REAL(wp), INTENT(in), DIMENSION(:,:)             ::   picefr     ! ice fraction                [0 to 1] 
    15811578      ! optional arguments, used only in 'mixed oce-ice' case 
    1582       REAL(wp), INTENT(in   ), DIMENSION(:,:,:), OPTIONAL ::   palbi      ! all skies ice albedo  
    1583       REAL(wp), INTENT(in   ), DIMENSION(:,:  ), OPTIONAL ::   psst       ! sea surface temperature     [Celsius] 
    1584       REAL(wp), INTENT(in   ), DIMENSION(:,:,:), OPTIONAL ::   pist       ! ice surface temperature     [Kelvin] 
     1579      REAL(wp), INTENT(in), DIMENSION(:,:,:), OPTIONAL ::   palbi      ! all skies ice albedo  
     1580      REAL(wp), INTENT(in), DIMENSION(:,:  ), OPTIONAL ::   psst       ! sea surface temperature     [Celsius] 
     1581      REAL(wp), INTENT(in), DIMENSION(:,:,:), OPTIONAL ::   pist       ! ice surface temperature     [Kelvin] 
    15851582      ! 
    15861583      INTEGER ::   jl         ! dummy loop index 
    1587       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zcptrain, zcptsnw, zicefr, zmsk, zsnw 
     1584      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw 
    15881585      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 
    15891586      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
    … …  
    15931590      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_ice_flx') 
    15941591      ! 
    1595       CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zcptrain, zcptsnw, zicefr, zmsk, zsnw ) 
     1592      CALL wrk_alloc( jpi,jpj,     zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw ) 
    15961593      CALL wrk_alloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
    15971594      CALL wrk_alloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
    … …  
    15991596 
    16001597      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    1601       zicefr(:,:) = 1.- p_frld(:,:) 
     1598      ziceld(:,:) = 1. - picefr(:,:) 
    16021599      zcptn(:,:) = rcp * sst_m(:,:) 
    16031600      ! 
    … …  
    16151612         ztprecip(:,:) =   frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
    16161613         zemp_tot(:,:) =   frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
    1617          zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 
    1618          IF( iom_use('precip') )          & 
    1619             &  CALL iom_put( 'precip'       ,   frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1)                              )  ! total  precipitation 
    1620          IF( iom_use('rain') )            & 
    1621             &  CALL iom_put( 'rain'         ,   frcv(jpr_rain)%z3(:,:,1)                                                         )  ! liquid precipitation  
    1622          IF( iom_use('rain_ao_cea') )   & 
    1623             &  CALL iom_put( 'rain_ao_cea'  , frcv(jpr_rain)%z3(:,:,1)* p_frld(:,:) * tmask(:,:,1)      )   ! liquid precipitation  
    1624          IF( iom_use('hflx_rain_cea') )   & 
    1625             CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) * tmask(:,:,1))   ! heat flux from liq. precip.  
    1626          IF( iom_use('hflx_prec_cea') )   & 
    1627             CALL iom_put( 'hflx_prec_cea', ztprecip * zcptn(:,:) * tmask(:,:,1) * p_frld(:,:) )   ! heat content flux from all precip  (cell avg) 
    1628          IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') )   & 
    1629             ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
    1630          IF( iom_use('evap_ao_cea'  ) )   & 
    1631             CALL iom_put( 'evap_ao_cea'  , ztmp * tmask(:,:,1)                  )   ! ice-free oce evap (cell average) 
    1632          IF( iom_use('hflx_evap_cea') )   & 
    1633             CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) * tmask(:,:,1) )   ! heat flux from from evap (cell average) 
     1614         zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * picefr(:,:) 
    16341615      CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    1635          zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    1636          zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) 
     1616         zemp_tot(:,:) = ziceld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + picefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
     1617         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * picefr(:,:) 
    16371618         zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 
    16381619         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 
    … …  
    16401621 
    16411622#if defined key_lim3 
    1642       ! zsnw = snow fraction over ice after wind blowing 
    1643       zsnw(:,:) = 0._wp  ;  CALL lim_thd_snwblow( p_frld, zsnw ) 
     1623      ! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing) 
     1624      zsnw(:,:) = 0._wp  ;  CALL ice_thd_snwblow( ziceld, zsnw ) 
    16441625       
    16451626      ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 
    1646       zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( zicefr(:,:) - zsnw(:,:) )  ! emp_ice = A * sublimation - zsnw * sprecip 
     1627      zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( picefr(:,:) - zsnw(:,:) )  ! emp_ice = A * sublimation - zsnw * sprecip 
    16471628      zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:)                                ! emp_oce = emp_tot - emp_ice 
    16481629 
    16491630      ! --- evaporation over ocean (used later for qemp) --- ! 
    1650       zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1631      zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) 
    16511632 
    16521633      ! --- evaporation over ice (kg/m2/s) --- ! 
    16531634      zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 
    16541635      ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 
    1655       ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 
     1636      ! therefore, sublimation is not redistributed over the ice categories when no subgrid scale fluxes are provided by atm. 
    16561637      zdevap_ice(:,:) = 0._wp 
    16571638       
    1658       ! --- runoffs (included in emp later on) --- ! 
    1659       IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
    1660  
    1661       ! --- calving (put in emp_tot and emp_oce) --- ! 
    1662       IF( srcv(jpr_cal)%laction ) THEN  
     1639      ! --- Continental fluxes --- ! 
     1640      IF( srcv(jpr_rnf)%laction ) THEN   ! runoffs (included in emp later on) 
     1641         rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1642      ENDIF 
     1643      IF( srcv(jpr_cal)%laction ) THEN   ! calving (put in emp_tot and emp_oce) 
    16631644         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    16641645         zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    1665          CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
    1666       ENDIF 
    1667  
    1668       IF( srcv(jpr_icb)%laction )  THEN  
     1646      ENDIF 
     1647      IF( srcv(jpr_icb)%laction ) THEN   ! iceberg added to runoffs 
    16691648         fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) 
    1670          rnf(:,:)    = rnf(:,:) + fwficb(:,:)   ! iceberg added to runoffs 
    1671          CALL iom_put( 'iceberg_cea', frcv(jpr_icb)%z3(:,:,1) ) 
    1672       ENDIF 
    1673       IF( srcv(jpr_isf)%laction )  THEN 
    1674         fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1)  ! fresh water flux from the isf (fwfisf <0 mean melting)   
    1675         CALL iom_put( 'iceshelf_cea', frcv(jpr_isf)%z3(:,:,1) ) 
    1676       ENDIF 
    1677  
     1649         rnf(:,:)    = rnf(:,:) + fwficb(:,:) 
     1650      ENDIF 
     1651      IF( srcv(jpr_isf)%laction ) THEN   ! iceshelf (fwfisf <0 mean melting) 
     1652        fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1)   
     1653      ENDIF 
    16781654 
    16791655      IF( ln_mixcpl ) THEN 
    … …  
    16991675      ENDIF 
    17001676 
    1701       IF( iom_use('subl_ai_cea') )   CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:)         )  ! Sublimation over sea-ice (cell average) 
    1702                                      CALL iom_put( 'snowpre'    , sprecip(:,:)                         )  ! Snow 
    1703       IF( iom_use('snow_ao_cea') )   CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw(:,:) ) )  ! Snow over ice-free ocean  (cell average) 
    1704       IF( iom_use('snow_ai_cea') )   CALL iom_put( 'snow_ai_cea', sprecip(:,:) *           zsnw(:,:)   )  ! Snow over sea-ice         (cell average) 
    17051677#else 
    1706       ! runoffs and calving (put in emp_tot) 
    1707       IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
    1708       IF( iom_use('hflx_rnf_cea') )   & 
    1709          CALL iom_put( 'hflx_rnf_cea' , rnf(:,:) * zcptn(:,:) ) 
    1710       IF( srcv(jpr_cal)%laction ) THEN  
     1678      zsnw(:,:) = picefr(:,:) 
     1679      ! --- Continental fluxes --- ! 
     1680      IF( srcv(jpr_rnf)%laction ) THEN   ! runoffs (included in emp later on) 
     1681         rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1682      ENDIF 
     1683      IF( srcv(jpr_cal)%laction ) THEN   ! calving (put in emp_tot) 
    17111684         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    1712          CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
    1713       ENDIF 
    1714  
    1715  
    1716       IF( srcv(jpr_icb)%laction )  THEN  
     1685      ENDIF 
     1686      IF( srcv(jpr_icb)%laction ) THEN   ! iceberg added to runoffs 
    17171687         fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) 
    1718          rnf(:,:)    = rnf(:,:) + fwficb(:,:)   ! iceberg added to runoffs 
    1719          CALL iom_put( 'iceberg_cea', frcv(jpr_icb)%z3(:,:,1) ) 
    1720       ENDIF 
    1721       IF( srcv(jpr_isf)%laction )  THEN 
    1722         fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1)  ! fresh water flux from the isf (fwfisf <0 mean melting)   
    1723         CALL iom_put( 'iceshelf_cea', frcv(jpr_isf)%z3(:,:,1) ) 
    1724       ENDIF 
    1725  
     1688         rnf(:,:)    = rnf(:,:) + fwficb(:,:) 
     1689      ENDIF 
     1690      IF( srcv(jpr_isf)%laction ) THEN   ! iceshelf (fwfisf <0 mean melting) 
     1691        fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1) 
     1692      ENDIF 
    17261693 
    17271694      IF( ln_mixcpl ) THEN 
    … …  
    17371704      ENDIF 
    17381705 
    1739       IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )  ! Sublimation over sea-ice (cell average) 
    1740                                     CALL iom_put( 'snowpre'    , sprecip(:,:)               )   ! Snow 
    1741       IF( iom_use('snow_ao_cea') )  CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) )   ! Snow over ice-free ocean  (cell average) 
    1742       IF( iom_use('snow_ai_cea') )  CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) )   ! Snow over sea-ice         (cell average) 
    17431706#endif 
    1744  
     1707      ! outputs 
     1708!!      IF( srcv(jpr_rnf)%laction )   CALL iom_put( 'runoffs' , rnf(:,:) * tmask(:,:,1)                                 )  ! runoff 
     1709!!      IF( srcv(jpr_isf)%laction )   CALL iom_put( 'iceshelf_cea', -fwfisf(:,:) * tmask(:,:,1)                         )  ! iceshelf 
     1710      IF( srcv(jpr_cal)%laction )   CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1)                )  ! calving 
     1711      IF( srcv(jpr_icb)%laction )   CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1)                )  ! icebergs 
     1712      IF( iom_use('snowpre') )      CALL iom_put( 'snowpre'     , sprecip(:,:)                                          )  ! Snow 
     1713      IF( iom_use('precip') )       CALL iom_put( 'precip'      , tprecip(:,:)                                          )  ! total  precipitation 
     1714      IF( iom_use('rain') )         CALL iom_put( 'rain'        , tprecip(:,:) - sprecip(:,:)                           )  ! liquid precipitation  
     1715      IF( iom_use('snow_ao_cea') )  CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) )                  )  ! Snow over ice-free ocean  (cell average) 
     1716      IF( iom_use('snow_ai_cea') )  CALL iom_put( 'snow_ai_cea' , sprecip(:,:) *           zsnw(:,:)                    )  ! Snow over sea-ice         (cell average) 
     1717      IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) )  ! Sublimation over sea-ice (cell average) 
     1718      IF( iom_use('evap_ao_cea') )  CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1)  & 
     1719         &                                                        - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) )  ! ice-free oce evap (cell average) 
     1720      ! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf 
     1721      ! 
    17451722      !                                                      ! ========================= ! 
    17461723      SELECT CASE( TRIM( sn_rcv_qns%cldes ) )                !   non solar heat fluxes   !   (qns) 
    … …  
    17581735         ENDIF 
    17591736      CASE( 'oce and ice' )      ! the total flux is computed from ocean and ice fluxes 
    1760          zqns_tot(:,:) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
     1737         zqns_tot(:,:) =  ziceld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
    17611738         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    17621739            DO jl=1,jpl 
    … …  
    17651742            ENDDO 
    17661743         ELSE 
    1767             qns_tot(:,:) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     1744            qns_tot(:,:) = qns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    17681745            DO jl=1,jpl 
    1769                zqns_tot(:,:   ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     1746               zqns_tot(:,:   ) = zqns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    17701747               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
    17711748            ENDDO 
    … …  
    17751752         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    17761753         zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
    1777             &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * p_frld(:,:)   & 
    1778             &                                           + pist(:,:,1) * zicefr(:,:) ) ) 
     1754            &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * ziceld(:,:)   & 
     1755            &                                           + pist(:,:,1) * picefr(:,:) ) ) 
    17791756      END SELECT 
    1780 !!gm 
    1781 !!    currently it is taken into account in leads budget but not in the zqns_tot, and thus not in  
    1782 !!    the flux that enter the ocean.... 
    1783 !!    moreover 1 - it is not diagnose anywhere....  
    1784 !!             2 - it is unclear for me whether this heat lost is taken into account in the atmosphere or not... 
    1785 !! 
    1786 !! similar job should be done for snow and precipitation temperature 
    17871757      !                                      
    1788       IF( srcv(jpr_cal)%laction ) THEN   ! Iceberg melting  
    1789          zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus  ! add the latent heat of iceberg melting 
    1790                                                                          ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean 
    1791          IF( iom_use('hflx_cal_cea') )   CALL iom_put( 'hflx_cal_cea', - frcv(jpr_cal)%z3(:,:,1) * lfus )   ! heat flux from calving 
    1792       ENDIF 
    1793  
    1794 !!chris      
    1795 !!    The heat content associated to the ice shelf in removed in the routine sbcisf.F90 
    1796       ! 
    1797       IF( srcv(jpr_icb)%laction )  zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_icb)%z3(:,:,1) * lfus ! remove heat content associated to iceberg melting 
    1798  
     1758      ! --- calving (removed from qns_tot) --- ! 
     1759      IF( srcv(jpr_cal)%laction )   zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus  ! remove latent heat of calving 
     1760                                                                                                    ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean 
     1761      ! --- iceberg (removed from qns_tot) --- ! 
     1762      IF( srcv(jpr_icb)%laction )   zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_icb)%z3(:,:,1) * lfus  ! remove latent heat of iceberg melting 
    17991763 
    18001764#if defined key_lim3       
    18011765      ! --- non solar flux over ocean --- ! 
    1802       !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
     1766      !         note: ziceld cannot be = 0 since we limit the ice concentration to amax 
    18031767      zqns_oce = 0._wp 
    1804       WHERE( p_frld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 
     1768      WHERE( ziceld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / ziceld(:,:) 
    18051769 
    18061770      ! Heat content per unit mass of snow (J/kg) 
    … …  
    18091773      ENDWHERE 
    18101774      ! Heat content per unit mass of rain (J/kg) 
    1811       zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * p_frld(:,:) )  
     1775      zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * ziceld(:,:) )  
    18121776 
    18131777      ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    … …  
    18221786      zqemp_oce(:,:) = -  zevap_oce(:,:)                                      *   zcptn   (:,:)   &        ! evap 
    18231787         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptrain(:,:)   &        ! liquid precip 
    1824          &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * zqprec_ice(:,:) * r1_rhosn ! solid precip over ocean + snow melting 
    1825       zqemp_ice(:,:) =     zsprecip(:,:)                   * zsnw             * zqprec_ice(:,:) * r1_rhosn ! solid precip over ice (qevap_ice=0 since atm. does not take it into account) 
    1826 !!    zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptsnw (:,:)   &        ! ice evap 
     1788         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptsnw (:,:) - lfus )  ! solid precip over ocean + snow melting 
     1789      zqemp_ice(:,:) =     zsprecip(:,:)                   * zsnw             * ( zcptsnw (:,:) - lfus )  ! solid precip over ice (qevap_ice=0 since atm. does not take it into account) 
     1790!!    zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * picefr(:,:)      *   zcptsnw (:,:)   &        ! ice evap 
    18271791!!       &             +   zsprecip(:,:)                   * zsnw             * zqprec_ice(:,:) * r1_rhosn ! solid precip over ice 
    18281792       
    … …  
    18511815      ENDIF 
    18521816 
    1853       ! some more outputs 
    1854       IF( iom_use('hflx_snow_cea') )    CALL iom_put('hflx_snow_cea',   sprecip(:,:) * ( zcptn(:,:) - Lfus ) )                       ! heat flux from snow (cell average) 
    1855       IF( iom_use('hflx_rain_cea') )    CALL iom_put('hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptn(:,:) )                 ! heat flux from rain (cell average) 
    1856       IF( iom_use('hflx_snow_ao_cea') ) CALL iom_put('hflx_snow_ao_cea',sprecip(:,:) * ( zcptn(:,:) - Lfus ) * (1._wp - zsnw(:,:)) ) ! heat flux from snow (cell average) 
    1857       IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put('hflx_snow_ai_cea',sprecip(:,:) * ( zcptn(:,:) - Lfus ) * zsnw(:,:) )           ! heat flux from snow (cell average) 
    1858  
    18591817#else 
     1818      zcptsnw (:,:) = zcptn(:,:) 
     1819      zcptrain(:,:) = zcptn(:,:) 
     1820       
    18601821      ! clem: this formulation is certainly wrong... but better than it was... 
    1861       zqns_tot(:,:) = zqns_tot(:,:)                       &            ! zqns_tot update over free ocean with: 
    1862          &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
    1863          &          - (  zemp_tot(:,:)                    &            ! remove the heat content of mass flux (assumed to be at SST) 
     1822      zqns_tot(:,:) = zqns_tot(:,:)                            &          ! zqns_tot update over free ocean with: 
     1823         &          - (  ziceld(:,:) * zsprecip(:,:) * lfus )  &          ! remove the latent heat flux of solid precip. melting 
     1824         &          - (  zemp_tot(:,:)                         &          ! remove the heat content of mass flux (assumed to be at SST) 
    18641825         &             - zemp_ice(:,:) ) * zcptn(:,:)  
    18651826 
    18661827     IF( ln_mixcpl ) THEN 
    1867          qns_tot(:,:) = qns(:,:) * p_frld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 )   ! total flux from blk 
     1828         qns_tot(:,:) = qns(:,:) * ziceld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 )   ! total flux from blk 
    18681829         qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) +  zqns_tot(:,:)* zmsk(:,:) 
    18691830         DO jl=1,jpl 
    … …  
    18741835         qns_ice(:,:,:) = zqns_ice(:,:,:) 
    18751836      ENDIF 
     1837 
    18761838#endif 
    1877  
     1839      ! outputs 
     1840      IF( srcv(jpr_cal)%laction )    CALL iom_put('hflx_cal_cea' , - frcv(jpr_cal)%z3(:,:,1) * lfus                                  ) ! latent heat from calving 
     1841      IF( srcv(jpr_icb)%laction )    CALL iom_put('hflx_icb_cea' , - frcv(jpr_icb)%z3(:,:,1) * lfus                                  ) ! latent heat from icebergs melting 
     1842      IF( iom_use('hflx_snow_cea') ) CALL iom_put('hflx_snow_cea',  sprecip(:,:) * ( zcptsnw(:,:) - Lfus )                           ) ! heat flux from snow (cell average) 
     1843      IF( iom_use('hflx_rain_cea') ) CALL iom_put('hflx_rain_cea',( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:)                    ) ! heat flux from rain (cell average) 
     1844      IF( iom_use('hflx_evap_cea') ) CALL iom_put('hflx_evap_cea',(frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) & ! heat flux from from evap (cell average) 
     1845         &                                                        ) * zcptn(:,:) * tmask(:,:,1) ) 
     1846      IF( iom_use('hflx_snow_ao_cea') ) CALL iom_put('hflx_snow_ao_cea',sprecip(:,:) * (zcptsnw(:,:) - Lfus) * (1._wp - zsnw(:,:))   ) ! heat flux from snow (over ocean) 
     1847      IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put('hflx_snow_ai_cea',sprecip(:,:) * (zcptsnw(:,:) - Lfus) *          zsnw(:,:)    ) ! heat flux from snow (over ice) 
     1848      ! note: hflx for runoff and iceshelf are done in sbcrnf and sbcisf resp. 
     1849      ! 
    18781850      !                                                      ! ========================= ! 
    18791851      SELECT CASE( TRIM( sn_rcv_qsr%cldes ) )                !      solar heat fluxes    !   (qsr) 
    … …  
    18941866         zqsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1) 
    18951867      CASE( 'oce and ice' ) 
    1896          zqsr_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) 
     1868         zqsr_tot(:,:  ) =  ziceld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) 
    18971869         IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 
    18981870            DO jl=1,jpl 
    … …  
    19011873            ENDDO 
    19021874         ELSE 
    1903             qsr_tot(:,:   ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
     1875            qsr_tot(:,:   ) = qsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
    19041876            DO jl=1,jpl 
    1905                zqsr_tot(:,:   ) = zqsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
     1877               zqsr_tot(:,:   ) = zqsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
    19061878               zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 
    19071879            ENDDO 
    … …  
    19131885!       ( see OASIS3 user guide, 5th edition, p39 ) 
    19141886         zqsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) )   & 
    1915             &            / (  1.- ( albedo_oce_mix(:,:  ) * p_frld(:,:)       & 
    1916             &                     + palbi         (:,:,1) * zicefr(:,:) ) ) 
     1887            &            / (  1.- ( albedo_oce_mix(:,:  ) * ziceld(:,:)       & 
     1888            &                     + palbi         (:,:,1) * picefr(:,:) ) ) 
    19171889      END SELECT 
    19181890      IF( ln_dm2dc .AND. ln_cpl ) THEN   ! modify qsr to include the diurnal cycle 
    … …  
    19251897#if defined key_lim3 
    19261898      ! --- solar flux over ocean --- ! 
    1927       !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
     1899      !         note: ziceld cannot be = 0 since we limit the ice concentration to amax 
    19281900      zqsr_oce = 0._wp 
    1929       WHERE( p_frld /= 0._wp )  zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / p_frld(:,:) 
     1901      WHERE( ziceld /= 0._wp )  zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / ziceld(:,:) 
    19301902 
    19311903      IF( ln_mixcpl ) THEN   ;   qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) +  zqsr_oce(:,:)* zmsk(:,:) 
    … …  
    19341906 
    19351907      IF( ln_mixcpl ) THEN 
    1936          qsr_tot(:,:) = qsr(:,:) * p_frld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 )   ! total flux from blk 
     1908         qsr_tot(:,:) = qsr(:,:) * ziceld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 )   ! total flux from blk 
    19371909         qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) +  zqsr_tot(:,:)* zmsk(:,:) 
    19381910         DO jl=1,jpl 
    … …  
    19751947 
    19761948      ! Surface transimission parameter io (Maykut Untersteiner , 1971 ; Ebert and Curry, 1993 ) 
    1977       ! Used for LIM2 and LIM3 
     1949      ! Used for LIM3 
    19781950      ! Coupled case: since cloud cover is not received from atmosphere  
    19791951      !               ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 
    … …  
    19811953      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    19821954 
    1983       CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zcptrain, zcptsnw, zicefr, zmsk, zsnw ) 
     1955      CALL wrk_dealloc( jpi,jpj,     zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw ) 
    19841956      CALL wrk_dealloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
    19851957      CALL wrk_dealloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
    … …  
    20271999            ! we must send the surface potential temperature  
    20282000            IF( l_useCT )  THEN    ;   ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 
    2029             ELSE                    ;   ztmp1(:,:) = tsn(:,:,1,jp_tem) 
     2001            ELSE                   ;   ztmp1(:,:) = tsn(:,:,1,jp_tem) 
    20302002            ENDIF 
    20312003            ! 
    … …  
    21402112            SELECT CASE( sn_snd_thick%clcat ) 
    21412113            CASE( 'yes' )    
    2142                ztmp3(:,:,1:jpl) =  ht_i(:,:,1:jpl) * a_i(:,:,1:jpl) 
    2143                ztmp4(:,:,1:jpl) =  ht_s(:,:,1:jpl) * a_i(:,:,1:jpl) 
     2114               ztmp3(:,:,1:jpl) =  h_i(:,:,1:jpl) * a_i(:,:,1:jpl) 
     2115               ztmp4(:,:,1:jpl) =  h_s(:,:,1:jpl) * a_i(:,:,1:jpl) 
    21442116            CASE( 'no' ) 
    21452117               ztmp3(:,:,:) = 0.0   ;  ztmp4(:,:,:) = 0.0 
    21462118               DO jl=1,jpl 
    2147                   ztmp3(:,:,1) = ztmp3(:,:,1) + ht_i(:,:,jl) * a_i(:,:,jl) 
    2148                   ztmp4(:,:,1) = ztmp4(:,:,1) + ht_s(:,:,jl) * a_i(:,:,jl) 
     2119                  ztmp3(:,:,1) = ztmp3(:,:,1) + h_i(:,:,jl) * a_i(:,:,jl) 
     2120                  ztmp4(:,:,1) = ztmp4(:,:,1) + h_s(:,:,jl) * a_i(:,:,jl) 
    21492121               ENDDO 
    21502122            CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 
    … …  
    21532125            SELECT CASE( sn_snd_thick%clcat ) 
    21542126            CASE( 'yes' ) 
    2155                ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) 
    2156                ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) 
     2127               ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) 
     2128               ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) 
    21572129            CASE( 'no' ) 
    21582130               WHERE( SUM( a_i, dim=3 ) /= 0. ) 
    2159                   ztmp3(:,:,1) = SUM( ht_i * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
    2160                   ztmp4(:,:,1) = SUM( ht_s * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
     2131                  ztmp3(:,:,1) = SUM( h_i * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
     2132                  ztmp4(:,:,1) = SUM( h_s * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
    21612133               ELSEWHERE 
    21622134                 ztmp3(:,:,1) = 0. 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r6140 r8586  
    1717   USE dom_oce        ! ocean space and time domain 
    1818   USE sbc_oce        ! surface ocean boundary condition 
     19   USE sbc_ice , ONLY : snwice_mass, snwice_mass_b, snwice_fmass 
    1920   USE phycst         ! physical constants 
    2021   USE sbcrnf         ! ocean runoffs 
    … …  
    9495         ! and in case of no melt, it can generate HSSW. 
    9596         ! 
    96 #if ! defined key_lim2 &&  ! defined key_lim3 && ! defined key_cice 
     97#if ! defined key_lim3 && ! defined key_cice 
    9798         snwice_mass_b(:,:) = 0.e0               ! no sea-ice model is being used : no snow+ice mass 
    9899         snwice_mass  (:,:) = 0.e0 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90

    r7646 r8586  
    137137            CALL cice_sbc_force(kt) 
    138138         ELSE IF ( ksbc == jp_purecpl ) THEN 
    139             CALL sbc_cpl_ice_flx( 1.0-fr_i ) 
     139            CALL sbc_cpl_ice_flx( fr_i ) 
    140140         ENDIF 
    141141 
    … …  
    230230      CALL lbc_lnk ( fr_iv , 'V', 1. ) 
    231231 
    232       !                                      ! embedded sea ice 
    233       IF( nn_ice_embd /= 0 ) THEN            ! mass exchanges between ice and ocean (case 1 or 2) set the snow+ice mass 
    234          CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) 
    235          CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) 
    236          snwice_mass  (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:)  ) 
    237          snwice_mass_b(:,:) = snwice_mass(:,:) 
    238       ELSE 
    239          snwice_mass  (:,:) = 0.0_wp         ! no mass exchanges 
    240          snwice_mass_b(:,:) = 0.0_wp         ! no mass exchanges 
    241       ENDIF 
     232      ! set the snow+ice mass 
     233      CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) 
     234      CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) 
     235      snwice_mass  (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:)  ) 
     236      snwice_mass_b(:,:) = snwice_mass(:,:) 
     237 
    242238      IF( .NOT.ln_rstart ) THEN 
    243          IF( nn_ice_embd == 2 ) THEN            ! full embedment (case 2) deplete the initial ssh below sea-ice area 
     239         IF( ln_ice_embd ) THEN            ! embedded sea-ice: deplete the initial ssh below sea-ice area 
    244240            sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0 
    245241            sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0 
    … …  
    473469      CALL nemo2cice(ztmp,vocn,'F', -1. ) 
    474470 
    475       IF( nn_ice_embd == 2 ) THEN             !== embedded sea ice: compute representative ice top surface ==! 
     471      IF( ln_ice_embd ) THEN             !== embedded sea ice: compute representative ice top surface ==! 
    476472          ! 
    477473          ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[n/nn_fsbc], n=0,nn_fsbc-1} 
    … …  
    676672      CALL lbc_lnk ( fr_iv , 'V', 1. ) 
    677673 
    678       !                                      ! embedded sea ice 
    679       IF( nn_ice_embd /= 0 ) THEN            ! mass exchanges between ice and ocean (case 1 or 2) set the snow+ice mass 
    680          CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) 
    681          CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) 
    682          snwice_mass  (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:)  ) 
    683          snwice_mass_b(:,:) = snwice_mass(:,:) 
    684          snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) / dt 
    685       ENDIF 
     674      ! set the snow+ice mass 
     675      CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) 
     676      CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) 
     677      snwice_mass  (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:)  ) 
     678      snwice_mass_b(:,:) = snwice_mass(:,:) 
     679      snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) / dt 
    686680 
    687681! Release work space 
    … …  
    727721 
    728722      DO jl = 1,ncat 
    729          CALL cice2nemo(vsnon(:,:,jl,:),ht_s(:,:,jl),'T', 1. ) 
    730          CALL cice2nemo(vicen(:,:,jl,:),ht_i(:,:,jl),'T', 1. ) 
     723         CALL cice2nemo( vsnon(:,:,jl,:), h_s(:,:,jl),'T', 1. ) 
     724         CALL cice2nemo( vicen(:,:,jl,:), h_i(:,:,jl),'T', 1. ) 
    731725      ENDDO 
    732726      ! 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90

    r8215 r8586  
    2424   USE fldread        ! read input field at current time step 
    2525   USE lbclnk         ! 
    26    USE wrk_nemo       ! Memory allocation 
    2726   USE timing         ! Timing 
    2827   USE lib_fortran    ! glob_sum 
    … …  
    3534   ! public in order to be able to output then  
    3635 
    37    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   risf_tsc_b, risf_tsc  !: before and now T & S isf contents [K.m/s & PSU.m/s]   
    38    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qisf                  !: net heat flux from ice shelf      [W/m2] 
    3936   REAL(wp), PUBLIC ::   rn_hisf_tbl                 !: thickness of top boundary layer [m] 
    4037   INTEGER , PUBLIC ::   nn_isf                      !: flag to choose between explicit/param/specified   
    … …  
    4441   REAL(wp), PUBLIC ::   rn_gammas0                  !: salinity    exchange coeficient [] 
    4542 
    46    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  rzisf_tbl              !:depth of calving front (shallowest point) nn_isf ==2/3 
    47    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  rhisf_tbl, rhisf_tbl_0 !:thickness of tbl  [m] 
    48    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  r1_hisf_tbl            !:1/thickness of tbl 
    49    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ralpha                 !:proportion of bottom cell influenced by tbl  
    50    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  risfLeff               !:effective length (Leff) BG03 nn_isf==2 
    51    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 
    52    INTEGER,    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)      ::  misfkt, misfkb         !:Level of ice shelf base 
     43   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   risf_tsc_b, risf_tsc  !: before and now T & S isf contents [K.m/s & PSU.m/s]   
     44   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qisf                  !: net heat flux from ice shelf      [W/m2] 
     45   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  rzisf_tbl              !:depth of calving front (shallowest point) nn_isf ==2/3 
     46   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  rhisf_tbl, rhisf_tbl_0 !:thickness of tbl  [m] 
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  r1_hisf_tbl            !:1/thickness of tbl 
     48   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  ralpha                 !:proportion of bottom cell influenced by tbl  
     49   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  risfLeff               !:effective length (Leff) BG03 nn_isf==2 
     50   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 
     51   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  misfkt, misfkb         !:Level of ice shelf base 
    5352 
    5453   LOGICAL, PUBLIC ::   l_isfcpl = .false.       ! isf recieved from oasis 
    … …  
    9089      !!                        4 : specified fwf and heat flux forcing beneath the ice shelf 
    9190      !!---------------------------------------------------------------------- 
    92       INTEGER, INTENT( in ) :: kt                   ! ocean time step 
    93       ! 
    94       INTEGER               :: ji, jj, jk           ! loop index 
    95       INTEGER               :: ikt, ikb             ! loop index 
     91      INTEGER, INTENT(in) ::   kt   ! ocean time step 
     92      ! 
     93      INTEGER :: ji, jj, jk   ! loop index 
     94      INTEGER :: ikt, ikb     ! local integers 
    9695      REAL(wp), DIMENSION(jpi,jpj) ::   zt_frz, zdep   ! freezing temperature (zt_frz) at depth (zdep)  
    97       REAL(wp), DIMENSION(:,:,:), POINTER :: zfwfisf3d, zqhcisf3d, zqlatisf3d 
    98       REAL(wp), DIMENSION(:,:  ), POINTER :: zqhcisf2d 
     96      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   zqhcisf2d 
     97      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zfwfisf3d, zqhcisf3d, zqlatisf3d 
    9998      !!--------------------------------------------------------------------- 
    10099      ! 
    101       IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    102  
    103          ! compute salt and heat flux 
     100      IF( MOD( kt-1, nn_fsbc) == 0 ) THEN    ! compute salt and heat flux 
     101         ! 
    104102         SELECT CASE ( nn_isf ) 
    105103         CASE ( 1 )    ! realistic ice shelf formulation 
    … …  
    119117            ELSE                        ;   qisf(:,:)  = fwfisf(:,:) * rlfusisf  ! heat        flux 
    120118            ENDIF 
    121  
     119            ! 
    122120         CASE ( 2 )    ! Beckmann and Goosse parametrisation  
    123121            stbl(:,:)   = soce 
    124122            CALL sbc_isf_bg03(kt) 
    125  
     123            ! 
    126124         CASE ( 3 )    ! specified runoff in depth (Mathiot et al., XXXX in preparation) 
    127125            ! specified runoff in depth (Mathiot et al., XXXX in preparation) 
    … …  
    132130            qisf(:,:)   = fwfisf(:,:) * rlfusisf             ! heat flux 
    133131            stbl(:,:)   = soce 
    134  
     132            ! 
    135133         CASE ( 4 )    ! specified fwf and heat flux forcing beneath the ice shelf 
    136            ! specified fwf and heat flux forcing beneath the ice shelf 
     134            !          ! specified fwf and heat flux forcing beneath the ice shelf 
    137135            IF( .NOT.l_isfcpl ) THEN 
    138136               CALL fld_read ( kt, nn_fsbc, sf_fwfisf   ) 
    … …  
    142140            qisf(:,:)   = fwfisf(:,:) * rlfusisf               ! heat flux 
    143141            stbl(:,:)   = soce 
    144  
     142            ! 
    145143         END SELECT 
    146144 
    … …  
    160158 
    161159         ! lbclnk 
    162          CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) 
    163          CALL lbc_lnk(risf_tsc(:,:,jp_sal),'T',1.) 
    164          CALL lbc_lnk(fwfisf(:,:)   ,'T',1.) 
    165          CALL lbc_lnk(qisf(:,:)     ,'T',1.) 
     160         CALL lbc_lnk( risf_tsc(:,:,jp_tem),'T',1.) 
     161         CALL lbc_lnk( risf_tsc(:,:,jp_sal),'T',1.) 
     162         CALL lbc_lnk( fwfisf  (:,:)       ,'T',1.) 
     163         CALL lbc_lnk( qisf    (:,:)       ,'T',1.) 
    166164 
    167165         ! output 
    168          CALL iom_put('qlatisf' , qisf) 
    169          CALL iom_put('fwfisf'  , fwfisf) 
    170  
    171         ! Diagnostics 
    172         IF ( iom_use('fwfisf3d') .OR. iom_use('qlatisf3d') .OR. iom_use('qhcisf3d') .OR. iom_use('qhcisf')) THEN 
    173             CALL wrk_alloc( jpi,jpj,jpk, zfwfisf3d, zqhcisf3d, zqlatisf3d ) 
    174             CALL wrk_alloc( jpi,jpj,     zqhcisf2d                        ) 
    175  
    176             zfwfisf3d(:,:,:) = 0.0_wp                         ! 3d ice shelf melting (kg/m2/s) 
    177             zqhcisf3d(:,:,:) = 0.0_wp                         ! 3d heat content flux (W/m2) 
    178             zqlatisf3d(:,:,:)= 0.0_wp                         ! 3d ice shelf melting latent heat flux (W/m2) 
    179             zqhcisf2d(:,:)   = fwfisf(:,:) * zt_frz * rcp     ! 2d heat content flux (W/m2) 
    180  
     166         IF( iom_use('iceshelf_cea') )   CALL iom_put( 'iceshelf_cea', -fwfisf(:,:)                      )   ! isf mass flux 
     167         IF( iom_use('hflx_isf_cea') )   CALL iom_put( 'hflx_isf_cea', risf_tsc(:,:,jp_tem) * rau0 * rcp )   ! isf sensible+latent heat (W/m2) 
     168         IF( iom_use('qlatisf' ) )       CALL iom_put( 'qlatisf'     , qisf(:,:)                         )   ! isf latent heat 
     169         IF( iom_use('fwfisf'  ) )       CALL iom_put( 'fwfisf'      , fwfisf(:,:)                       )   ! isf mass flux (opposite sign) 
     170 
     171         ! Diagnostics 
     172         IF( iom_use('fwfisf3d') .OR. iom_use('qlatisf3d') .OR. iom_use('qhcisf3d') .OR. iom_use('qhcisf')) THEN 
     173            ALLOCATE( zfwfisf3d(jpi,jpj,jpk) , zqhcisf3d(jpi,jpj,jpk) , zqlatisf3d(jpi,jpj,jpk) ) 
     174            ALLOCATE( zqhcisf2d(jpi,jpj) ) 
     175            ! 
     176            zfwfisf3d (:,:,:) = 0._wp                         ! 3d ice shelf melting (kg/m2/s) 
     177            zqhcisf3d (:,:,:) = 0._wp                         ! 3d heat content flux (W/m2) 
     178            zqlatisf3d(:,:,:) = 0._wp                         ! 3d ice shelf melting latent heat flux (W/m2) 
     179            zqhcisf2d (:,:)   = fwfisf(:,:) * zt_frz * rcp    ! 2d heat content flux (W/m2) 
     180            ! 
    181181            DO jj = 1,jpj 
    182182               DO ji = 1,jpi 
    … …  
    193193               END DO 
    194194            END DO 
    195  
     195            ! 
    196196            CALL iom_put('fwfisf3d' , zfwfisf3d (:,:,:)) 
    197197            CALL iom_put('qlatisf3d', zqlatisf3d(:,:,:)) 
    198198            CALL iom_put('qhcisf3d' , zqhcisf3d (:,:,:)) 
    199199            CALL iom_put('qhcisf'   , zqhcisf2d (:,:  )) 
    200  
    201             CALL wrk_dealloc( jpi,jpj,jpk, zfwfisf3d, zqhcisf3d, zqlatisf3d ) 
    202             CALL wrk_dealloc( jpi,jpj,     zqhcisf2d                        ) 
    203           END IF 
    204           ! 
    205         END IF 
    206  
    207         IF( kt == nit000 ) THEN                         !   set the forcing field at nit000 - 1    ! 
    208            IF( ln_rstart .AND.    &                     ! Restart: read in restart file 
    209                  & iom_varid( numror, 'fwf_isf_b', ldstop = .FALSE. ) > 0 ) THEN 
    210                IF(lwp) WRITE(numout,*) '          nit000-1 isf tracer content forcing fields read in the restart file' 
    211                CALL iom_get( numror, jpdom_autoglo, 'fwf_isf_b', fwfisf_b(:,:) )   ! before salt content isf_tsc trend 
    212                CALL iom_get( numror, jpdom_autoglo, 'isf_sc_b', risf_tsc_b(:,:,jp_sal) )   ! before salt content isf_tsc trend 
    213                CALL iom_get( numror, jpdom_autoglo, 'isf_hc_b', risf_tsc_b(:,:,jp_tem) )   ! before salt content isf_tsc trend 
    214            ELSE 
    215                fwfisf_b(:,:)    = fwfisf(:,:) 
    216                risf_tsc_b(:,:,:)= risf_tsc(:,:,:) 
    217            END IF 
    218          END IF 
    219          !  
    220          IF( lrst_oce ) THEN 
    221             IF(lwp) WRITE(numout,*) 
    222             IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ',   & 
    223                &                    'at it= ', kt,' date= ', ndastp 
    224             IF(lwp) WRITE(numout,*) '~~~~' 
    225             CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:) ) 
    226             CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem) ) 
    227             CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal) ) 
     200            ! 
     201            DEALLOCATE( zfwfisf3d, zqhcisf3d, zqlatisf3d ) 
     202            DEALLOCATE( zqhcisf2d ) 
    228203         ENDIF 
    229204         ! 
    230   END SUBROUTINE sbc_isf 
    231  
    232  
    233   INTEGER FUNCTION sbc_isf_alloc() 
     205      ENDIF 
     206 
     207      IF( kt == nit000 ) THEN                         !   set the forcing field at nit000 - 1    ! 
     208         IF( ln_rstart .AND.    &                     ! Restart: read in restart file 
     209            &   iom_varid( numror, 'fwf_isf_b', ldstop = .FALSE. ) > 0 ) THEN 
     210            IF(lwp) WRITE(numout,*) '          nit000-1 isf tracer content forcing fields read in the restart file' 
     211            CALL iom_get( numror, jpdom_autoglo, 'fwf_isf_b', fwfisf_b(:,:) )   ! before salt content isf_tsc trend 
     212            CALL iom_get( numror, jpdom_autoglo, 'isf_sc_b', risf_tsc_b(:,:,jp_sal) )   ! before salt content isf_tsc trend 
     213            CALL iom_get( numror, jpdom_autoglo, 'isf_hc_b', risf_tsc_b(:,:,jp_tem) )   ! before salt content isf_tsc trend 
     214         ELSE 
     215            fwfisf_b(:,:)    = fwfisf(:,:) 
     216            risf_tsc_b(:,:,:)= risf_tsc(:,:,:) 
     217         ENDIF 
     218      ENDIF 
     219      !  
     220      IF( lrst_oce ) THEN 
     221         IF(lwp) WRITE(numout,*) 
     222         IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ',   & 
     223            &                    'at it= ', kt,' date= ', ndastp 
     224         IF(lwp) WRITE(numout,*) '~~~~' 
     225         CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:) ) 
     226         CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem) ) 
     227         CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal) ) 
     228      ENDIF 
     229      ! 
     230   END SUBROUTINE sbc_isf 
     231 
     232 
     233   INTEGER FUNCTION sbc_isf_alloc() 
    234234      !!---------------------------------------------------------------------- 
    235235      !!               ***  FUNCTION sbc_isf_rnf_alloc  *** 
    … …  
    247247         IF( sbc_isf_alloc /= 0 )   CALL ctl_warn('sbc_isf_alloc: failed to allocate arrays.') 
    248248         ! 
    249       END IF 
    250   END FUNCTION 
     249      ENDIF 
     250   END FUNCTION 
    251251 
    252252 
    … …  
    715715      INTEGER ::   ikt, ikb                    ! top and bottom index of the tbl 
    716716      REAL(wp) ::   ze3, zhk 
    717       REAL(wp), DIMENSION(:,:), POINTER :: zhisf_tbl ! thickness of the tbl 
    718       !!---------------------------------------------------------------------- 
    719       ! allocation 
    720       CALL wrk_alloc( jpi,jpj, zhisf_tbl) 
     717      REAL(wp), DIMENSION(jpi,jpj) :: zhisf_tbl ! thickness of the tbl 
     718      !!---------------------------------------------------------------------- 
    721719       
    722720      ! initialisation 
    … …  
    806804         END DO 
    807805      END SELECT 
    808  
     806      ! 
    809807      ! mask mean tbl value 
    810808      pvarout(:,:) = pvarout(:,:) * ssmask(:,:) 
    811  
    812       ! deallocation 
    813       CALL wrk_dealloc( jpi,jpj, zhisf_tbl )       
    814809      ! 
    815810   END SUBROUTINE sbc_isf_tbl 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r7822 r8586  
    3333   USE sbcblk         ! surface boundary condition: bulk formulation 
    3434   USE sbcice_if      ! surface boundary condition: ice-if sea-ice model 
    35    USE sbcice_lim     ! surface boundary condition: LIM 3.0 sea-ice model 
    36    USE sbcice_lim_2   ! surface boundary condition: LIM 2.0 sea-ice model 
     35#if defined key_lim3 
     36   USE icestp         ! surface boundary condition: LIM 3.0 sea-ice model 
     37#endif 
    3738   USE sbcice_cice    ! surface boundary condition: CICE    sea-ice model 
    3839   USE sbcisf         ! surface boundary condition: ice-shelf 
    … …  
    9091      NAMELIST/namsbc/ nn_fsbc  ,                                                    & 
    9192         &             ln_usr   , ln_flx   , ln_blk       ,                          & 
    92          &             ln_cpl   , ln_mixcpl, nn_components, nn_limflx,               & 
    93          &             nn_ice   , nn_ice_embd,                                       & 
     93         &             ln_cpl   , ln_mixcpl, nn_components,                          & 
     94         &             nn_ice   , ln_ice_embd,                                       & 
    9495         &             ln_traqsr, ln_dm2dc ,                                         & 
    9596         &             ln_rnf   , nn_fwb   , ln_ssr   , ln_isf    , ln_apr_dyn ,     & 
    … …  
    117118#if defined key_agrif 
    118119      IF( Agrif_Root() ) THEN                ! AGRIF zoom (cf r1242: possibility to run without ice in fine grid) 
    119          IF( lk_lim2 )   nn_ice      = 2 
    120          IF( lk_lim3 )   nn_ice      = 3 
    121          IF( lk_cice )   nn_ice      = 4 
     120         IF( lk_lim3 )   nn_ice      = 2 
     121         IF( lk_cice )   nn_ice      = 3 
    122122      ENDIF 
    123123#else 
    124       IF( lk_lim2 )   nn_ice      = 2 
    125       IF( lk_lim3 )   nn_ice      = 3 
    126       IF( lk_cice )   nn_ice      = 4 
     124      IF( lk_lim3 )   nn_ice      = 2 
     125      IF( lk_cice )   nn_ice      = 3 
    127126#endif 
    128127      ! 
    … …  
    140139         WRITE(numout,*) '         OASIS coupling (with atm or sas)           lk_oasis      = ', lk_oasis 
    141140         WRITE(numout,*) '         components of your executable              nn_components = ', nn_components 
    142          WRITE(numout,*) '         Multicategory heat flux formulation (LIM3) nn_limflx     = ', nn_limflx 
    143141         WRITE(numout,*) '      Sea-ice : ' 
    144142         WRITE(numout,*) '         ice management in the sbc (=0/1/2/3)       nn_ice        = ', nn_ice 
    145          WRITE(numout,*) '         ice-ocean embedded/levitating (=0/1/2)     nn_ice_embd   = ', nn_ice_embd 
     143         WRITE(numout,*) '         ice embedded into ocean                    ln_ice_embd   = ', ln_ice_embd 
    146144         WRITE(numout,*) '      Misc. options of sbc : ' 
    147145         WRITE(numout,*) '         Light penetration in temperature Eq.       ln_traqsr     = ', ln_traqsr 
    … …  
    201199      CASE( 0 )                        !- no ice in the domain 
    202200      CASE( 1 )                        !- Ice-cover climatology ("Ice-if" model)   
    203       CASE( 2 )                        !- LIM2 ice model 
    204          IF( .NOT.( ln_blk .OR. ln_cpl ) )   CALL ctl_stop( 'sbc_init : LIM2 sea-ice model requires ln_blk or ln_cpl = T' ) 
    205       CASE( 3 )                        !- LIM3 ice model 
    206          IF( nn_ice_embd == 0            )   CALL ctl_stop( 'sbc_init : LIM3 sea-ice models require nn_ice_embd = 1 or 2' ) 
    207       CASE( 4 )                        !- CICE ice model 
     201      CASE( 2 )                        !- LIM3 ice model 
     202      CASE( 3 )                        !- CICE ice model 
    208203         IF( .NOT.( ln_blk .OR. ln_cpl ) )   CALL ctl_stop( 'sbc_init : CICE sea-ice model requires ln_blk or ln_cpl = T' ) 
    209          IF( nn_ice_embd == 0            )   CALL ctl_stop( 'sbc_init : CICE sea-ice models require nn_ice_embd = 1 or 2' ) 
    210204         IF( lk_agrif                    )   CALL ctl_stop( 'sbc_init : CICE sea-ice model not currently available with AGRIF' )  
    211205      CASE DEFAULT                     !- not supported 
    212206      END SELECT 
    213207      ! 
    214       IF( nn_ice == 3 ) THEN           !- LIM3 case: multi-category flux option 
    215          IF(lwp) WRITE(numout,*) 
    216          SELECT CASE( nn_limflx )         ! LIM3 Multi-category heat flux formulation 
    217          CASE ( -1 ) 
    218             IF(lwp) WRITE(numout,*) '   LIM3: use per-category fluxes (nn_limflx = -1) ' 
    219             IF( ln_cpl )   CALL ctl_stop( 'sbc_init : the chosen nn_limflx for LIM3 in coupled mode must be 0 or 2' ) 
    220          CASE ( 0  ) 
    221             IF(lwp) WRITE(numout,*) '   LIM3: use average per-category fluxes (nn_limflx = 0) ' 
    222          CASE ( 1  ) 
    223             IF(lwp) WRITE(numout,*) '   LIM3: use average then redistribute per-category fluxes (nn_limflx = 1) ' 
    224             IF( ln_cpl )   CALL ctl_stop( 'sbc_init : the chosen nn_limflx for LIM3 in coupled mode must be 0 or 2' ) 
    225          CASE ( 2  ) 
    226             IF(lwp) WRITE(numout,*) '   LIM3: Redistribute a single flux over categories (nn_limflx = 2) ' 
    227             IF( .NOT.ln_cpl )   CALL ctl_stop( 'sbc_init : the chosen nn_limflx for LIM3 in forced mode cannot be 2' ) 
    228          CASE DEFAULT 
    229             CALL ctl_stop( 'sbcmod: LIM3 option, nn_limflx, should be between -1 and 2' ) 
    230          END SELECT 
    231       ELSE                             ! other sea-ice model 
    232          IF( nn_limflx >= 0  )   CALL ctl_warn( 'sbc_init : multi-category flux option (nn_limflx) only available in LIM3' ) 
    233       ENDIF 
    234       ! 
    235208      !                       !**  allocate and set required variables 
    236209      ! 
    237210      !                             !* allocate sbc arrays 
    238211      IF( sbc_oce_alloc() /= 0 )   CALL ctl_stop( 'sbc_init : unable to allocate sbc_oce arrays' ) 
     212#if ! defined key_lim3 && ! defined key_cice 
     213      IF( sbc_ice_alloc() /= 0 )   CALL ctl_stop( 'sbc_init : unable to allocate sbc_ice arrays' ) 
     214#endif 
    239215      ! 
    240216      IF( .NOT.ln_isf ) THEN        !* No ice-shelf in the domain : allocate and set to zero 
    … …  
    328304      IF( ln_ssr      )   CALL sbc_ssr_init            ! Sea-Surface Restoring initialization 
    329305      ! 
    330       IF( ln_isf      )   CALL sbc_isf_init               ! Compute iceshelves 
     306      IF( ln_isf      )   CALL sbc_isf_init            ! Compute iceshelves 
    331307      ! 
    332308                          CALL sbc_rnf_init            ! Runof initialization 
    333309      ! 
    334       IF( nn_ice == 3 )   CALL sbc_lim_init            ! LIM3 initialization 
    335       ! 
    336       IF( nn_ice == 4 )   CALL cice_sbc_init( nsbc )   ! CICE initialization 
    337       ! 
    338       IF( ln_wave     )   CALL sbc_wave_init              ! surface wave initialisation 
     310#if defined key_lim3 
     311           IF    ( lk_agrif .AND. nn_ice == 0 ) THEN 
     312                          IF( sbc_ice_alloc() /= 0 )   CALL ctl_stop('STOP', 'sbc_ice_alloc : unable to allocate arrays' )  ! clem2017: allocate ice arrays in case agrif + lim + no-ice in child grid 
     313           ELSEIF( nn_ice == 2 ) THEN 
     314                          CALL ice_init                ! LIM3 initialization 
     315           ENDIF 
     316#endif 
     317      IF( nn_ice == 3 )   CALL cice_sbc_init( nsbc )   ! CICE initialization 
     318      ! 
     319      IF( ln_wave     )   CALL sbc_wave_init           ! surface wave initialisation 
    339320      ! 
    340321   END SUBROUTINE sbc_init 
    … …  
    425406      ! 
    426407      SELECT CASE( nn_ice )                                       ! Update heat and freshwater fluxes over sea-ice areas 
    427       CASE(  1 )   ;         CALL sbc_ice_if   ( kt )                ! Ice-cover climatology ("Ice-if" model) 
    428       CASE(  2 )   ;         CALL sbc_ice_lim_2( kt, nsbc )          ! LIM-2 ice model 
    429       CASE(  3 )   ;         CALL sbc_ice_lim  ( kt, nsbc )          ! LIM-3 ice model 
    430       CASE(  4 )   ;         CALL sbc_ice_cice ( kt, nsbc )          ! CICE ice model 
     408      CASE(  1 )   ;         CALL sbc_ice_if   ( kt )             ! Ice-cover climatology ("Ice-if" model) 
     409#if defined key_lim3 
     410      CASE(  2 )   ;         CALL ice_stp  ( kt, nsbc )           ! LIM-3 ice model 
     411#endif 
     412      CASE(  3 )   ;         CALL sbc_ice_cice ( kt, nsbc )       ! CICE ice model 
    431413      END SELECT 
    432414 
    … …  
    536518      !!--------------------------------------------------------------------- 
    537519      ! 
    538       IF( nn_ice == 4 )   CALL cice_sbc_final 
     520      IF( nn_ice == 3 )   CALL cice_sbc_final 
    539521      ! 
    540522   END SUBROUTINE sbc_final 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r7753 r8586  
    138138         IF( ln_rnf_sal )   rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
    139139         !                                                           ! else use S=0 for runoffs (done one for all in the init) 
    140          CALL iom_put( "runoffs", rnf )         ! output runoffs arrays 
     140         IF( iom_use('runoffs') )        CALL iom_put( 'runoffs'     , rnf(:,:)                         )   ! output runoff mass flux 
     141         IF( iom_use('hflx_rnf_cea') )   CALL iom_put( 'hflx_rnf_cea', rnf_tsc(:,:,jp_tem) * rau0 * rcp )   ! output runoff sensible heat (W/m2) 
    141142      ENDIF 
    142143      ! 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90

    r7753 r8586  
    121121         ssu_m(:,:) = ssu_m(:,:) + ub(:,:,1) 
    122122         ssv_m(:,:) = ssv_m(:,:) + vb(:,:,1) 
    123          IF( l_useCT )  THEN    ;   sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
     123         IF( l_useCT )  THEN     ;   sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    124124         ELSE                    ;   sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem) 
    125125         ENDIF 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90

    r8215 r8586  
    137137         END DO 
    138138      END DO    
    139       CALL lbc_lnk( usd(:,:,:), 'U', vsd(:,:,:), 'V', -1. ) 
     139      CALL lbc_lnk( usd(:,:,:), 'U', -1. ) 
     140      CALL lbc_lnk( vsd(:,:,:), 'V', -1. ) 
     141 
     142 
    140143      ! 
    141144      !                       !==  vertical Stokes Drift 3D velocity  ==! 
    … …  
    152155      END DO 
    153156      ! 
    154       IF( .NOT. AGRIF_Root() ) THEN 
    155          IF( nbondi ==  1 .OR. nbondi == 2 )   ze3divh(nlci-1,   :  ,:) = 0._wp      ! east 
    156          IF( nbondi == -1 .OR. nbondi == 2 )   ze3divh(  2   ,   :  ,:) = 0._wp      ! west 
    157          IF( nbondj ==  1 .OR. nbondj == 2 )   ze3divh(  :   ,nlcj-1,:) = 0._wp      ! north 
    158          IF( nbondj == -1 .OR. nbondj == 2 )   ze3divh(  :   ,  2   ,:) = 0._wp      ! south 
    159       ENDIF 
     157#if defined key_agrif 
     158      IF( .NOT. Agrif_Root() ) THEN 
     159         IF( nbondi == -1 .OR. nbondi == 2 )   ze3divh( 2:nbghostcells+1,:        ,:) = 0._wp      ! west 
     160         IF( nbondi ==  1 .OR. nbondi == 2 )   ze3divh( nlci-nbghostcells:nlci-1,:,:) = 0._wp      ! east 
     161         IF( nbondj == -1 .OR. nbondj == 2 )   ze3divh( :,2:nbghostcells+1        ,:) = 0._wp      ! south 
     162         IF( nbondj ==  1 .OR. nbondj == 2 )   ze3divh( :,nlcj-nbghostcells:nlcj-1,:) = 0._wp      ! north 
     163      ENDIF 
     164#endif 
    160165      ! 
    161166      CALL lbc_lnk( ze3divh, 'T', 1. ) 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90

    r8568 r8586  
    346346         END DO 
    347347         !                                 ! trend diagnostics 
    348          IF( l_trd )                     CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 
     348         IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 
    349349         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    350          IF( l_ptr )                     CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 
     350         IF( l_ptr )   CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 
    351351         ! 
    352352      END DO 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90

    r8568 r8586  
    2020   USE diaptr         ! poleward transport diagnostics 
    2121   USE diaar5         ! AR5 diagnostics 
    22  
    2322   ! 
    24    USE iom            ! XIOS library 
     23   USE iom            ! I/O library 
    2524   USE lib_mpp        ! massively parallel library 
    2625   USE lbclnk         ! ocean lateral boundary condition (or mpp link) 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r8568 r8586  
    4747   LOGICAL , PUBLIC ::   ln_qsr_2bd   !: 2 band         light absorption flag 
    4848   LOGICAL , PUBLIC ::   ln_qsr_bio   !: bio-model      light absorption flag 
    49    LOGICAL , PUBLIC ::   ln_qsr_ice   !: light penetration for ice-model LIM3 (clem) 
    5049   INTEGER , PUBLIC ::   nn_chldta    !: use Chlorophyll data (=1) or not (=0) 
    5150   REAL(wp), PUBLIC ::   rn_abs       !: fraction absorbed in the very near surface (RGB & 2 bands) 
    … …  
    268267      END DO 
    269268      ! 
    270       IF( ln_qsr_ice ) THEN      ! sea-ice: store the 1st ocean level attenuation coefficient 
    271          DO jj = 2, jpjm1  
    272             DO ji = fs_2, fs_jpim1   ! vector opt. 
    273                IF( qsr(ji,jj) /= 0._wp ) THEN   ;   fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) 
    274                ELSE                             ;   fraqsr_1lev(ji,jj) = 1._wp 
    275                ENDIF 
    276             END DO 
    277          END DO 
    278          ! Update haloes since lim_thd needs fraqsr_1lev to be defined everywhere 
    279          CALL lbc_lnk( fraqsr_1lev(:,:), 'T', 1._wp ) 
    280       ENDIF 
     269      ! sea-ice: store the 1st ocean level attenuation coefficient 
     270      DO jj = 2, jpjm1  
     271         DO ji = fs_2, fs_jpim1   ! vector opt. 
     272            IF( qsr(ji,jj) /= 0._wp ) THEN   ;   fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) 
     273            ELSE                             ;   fraqsr_1lev(ji,jj) = 1._wp 
     274            ENDIF 
     275         END DO 
     276      END DO 
     277      CALL lbc_lnk( fraqsr_1lev(:,:), 'T', 1._wp ) 
    281278      ! 
    282279      IF( iom_use('qsr3d') ) THEN      ! output the shortwave Radiation distribution 
    … …  
    333330      TYPE(FLD_N)        ::   sn_chl   ! informations about the chlorofyl field to be read 
    334331      !! 
    335       NAMELIST/namtra_qsr/  sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, ln_qsr_ice, & 
     332      NAMELIST/namtra_qsr/  sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, & 
    336333         &                  nn_chldta, rn_abs, rn_si0, rn_si1 
    337334      !!---------------------------------------------------------------------- 
    … …  
    356353         WRITE(numout,*) '      2 band               light penetration       ln_qsr_2bd = ', ln_qsr_2bd 
    357354         WRITE(numout,*) '      bio-model            light penetration       ln_qsr_bio = ', ln_qsr_bio 
    358          WRITE(numout,*) '      light penetration for ice-model (LIM3)       ln_qsr_ice = ', ln_qsr_ice 
    359355         WRITE(numout,*) '      RGB : Chl data (=1) or cst value (=0)        nn_chldta  = ', nn_chldta 
    360356         WRITE(numout,*) '      RGB & 2 bands: fraction of light (rn_si1)    rn_abs     = ', rn_abs 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90

    r8568 r8586  
    5050      !! ** Purpose :   compute the vertical ocean tracer physics. 
    5151      !!--------------------------------------------------------------------- 
    52       INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    53       ! 
    54       INTEGER  ::   jk                   ! Dummy loop indices 
     52      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     53      ! 
     54      INTEGER  ::   jk   ! Dummy loop indices 
    5555      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace 
    5656      !!--------------------------------------------------------------------- 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/USR/usrdef_sbc.F90

    r7753 r8586  
    2727 
    2828   PUBLIC   usrdef_sbc_oce    ! routine called in sbcmod module 
    29    PUBLIC   usrdef_sbc_ice_tau  ! routine called by sbcice_lim.F90 for ice dynamics 
    30    PUBLIC   usrdef_sbc_ice_flx  ! routine called by sbcice_lim.F90 for ice thermo 
     29   PUBLIC   usrdef_sbc_ice_tau  ! routine called by icestp.F90 for ice dynamics 
     30   PUBLIC   usrdef_sbc_ice_flx  ! routine called by icestp.F90 for ice thermo 
    3131 
    3232   !! * Substitutions 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90

    r8215 r8586  
    4545 
    4646   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm, avt, avs  !: vertical mixing coefficients (w-point) [m2/s] 
    47    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avm_k , avt_k  !: Kz computed by turbulent closure alone [m2/s] 
    48    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en             !: now turbulent kinetic energy          [m2/s2] 
     47   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm_k , avt_k  !: Kz computed by turbulent closure alone [m2/s] 
     48   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   en             !: now turbulent kinetic energy          [m2/s2] 
    4949   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:)     ::   avmb , avtb    !: background profile of avm and avt      [m2/s] 
    5050   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   avtb_2d        !: horizontal shape of background Kz profile [-] 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r8568 r8586  
    199199         zhsro(:,:) = MAX( rsbc_zs1 * ustar2_surf(:,:) , rn_hsro ) 
    200200      CASE ( 2 )             ! Roughness formulae according to Rascle et al., Ocean Modelling (2008) 
     201!!gm faster coding : the 2 comment lines should be used 
    201202!!gm         zcof = 2._wp * 0.6_wp / 28._wp 
    202 !!gm         zdep(:,:)  = 30._wp * TANH(  zcof/ SQRT( MAX(ustar2_surf(:,:),rsmall) )  )      ! Wave age (eq. 10) 
    203          zdep (:,:) = 30.*TANH( 2.*0.3/(28.*SQRT(MAX(ustar2_surf(:,:),rsmall))) )            ! Wave age (eq. 10) 
    204          zhsro(:,:) = MAX(rsbc_zs2 * ustar2_surf(:,:) * zdep(:,:)**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11) 
     203!!gm         zdep(:,:)  = 30._wp * TANH(  zcof/ SQRT( MAX(ustar2_surf(:,:),rsmall) )  )       ! Wave age (eq. 10) 
     204         zdep (:,:) = 30.*TANH( 2.*0.3/(28.*SQRT(MAX(ustar2_surf(:,:),rsmall))) )         ! Wave age (eq. 10) 
     205         zhsro(:,:) = MAX(rsbc_zs2 * ustar2_surf(:,:) * zdep(:,:)**1.5, rn_hsro)          ! zhsro = rn_frac_hs * Hsw (eq. 11) 
    205206      CASE ( 3 )             ! Roughness given by the wave model (coupled or read in file) 
    206 !!gm  BUG missing a multiplicative coefficient.... 
    207          zhsro(:,:) = hsw(:,:) 
     207         zhsro(:,:) = rn_frac_hs * hsw(:,:)   ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 ) 
    208208      END SELECT 
    209209      ! 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r8568 r8586  
    5050   USE usrdef_nam     ! user defined configuration 
    5151   USE tideini        ! tidal components initialization   (tide_ini routine) 
    52    USE bdy_oce,   ONLY: ln_bdy 
     52   USE bdy_oce,  ONLY : ln_bdy 
    5353   USE bdyini         ! open boundary cond. setting       (bdy_init routine) 
    5454   USE istate         ! initial state setting          (istate_init routine) 
    … …  
    138138# if defined key_top 
    139139      CALL Agrif_Declare_Var_top   !  "      "   "   "      "  TOP 
    140 # endif 
    141 # if defined key_lim2 
    142       CALL Agrif_Declare_Var_lim2  !  "      "   "   "      "  LIM2 
    143140# endif 
    144141# if defined key_lim3 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/oce.F90

    r8215 r8586  
    6363   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   riceload 
    6464 
    65    !! arrays relating to embedding ice in the ocean. These arrays need to be declared  
    66    !! even if no ice model is required. In the no ice model or traditional levitating  
    67    !! ice cases they contain only zeros 
    68    !! --------------------- 
    69    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_mass        !: mass of snow and ice at current  ice time step   [Kg/m2] 
    70    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_mass_b      !: mass of snow and ice at previous ice time step   [Kg/m2] 
    71    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_fmass       !: time evolution of mass of snow+ice               [Kg/m2/s] 
    72  
    7365   !! Energy budget of the leads (open water embedded in sea ice) 
    7466   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fraqsr_1lev        !: fraction of solar net radiation absorbed in the first ocean level [-] 
    … …  
    8577      !!                   ***  FUNCTION oce_alloc  *** 
    8678      !!---------------------------------------------------------------------- 
    87       INTEGER :: ierr(7) 
     79      INTEGER :: ierr(6) 
    8880      !!---------------------------------------------------------------------- 
    8981      ! 
    … …  
    10799         &      riceload(jpi,jpj)                                     , STAT=ierr(2) ) 
    108100         ! 
    109       ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(3) ) 
    110          ! 
    111       ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(4) ) 
     101      ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(3) ) 
    112102         ! 
    113103      ALLOCATE( ssha_e(jpi,jpj),  sshn_e(jpi,jpj), sshb_e(jpi,jpj), sshbb_e(jpi,jpj), & 
    114104         &        ua_e(jpi,jpj),    un_e(jpi,jpj),   ub_e(jpi,jpj),   ubb_e(jpi,jpj), & 
    115105         &        va_e(jpi,jpj),    vn_e(jpi,jpj),   vb_e(jpi,jpj),   vbb_e(jpi,jpj), & 
    116          &        hu_e(jpi,jpj),   hur_e(jpi,jpj),   hv_e(jpi,jpj),   hvr_e(jpi,jpj), STAT=ierr(5) ) 
     106         &        hu_e(jpi,jpj),   hur_e(jpi,jpj),   hv_e(jpi,jpj),   hvr_e(jpi,jpj), STAT=ierr(4) ) 
    117107         ! 
    118       ALLOCATE( ub2_b(jpi,jpj), vb2_b(jpi,jpj)                                      , STAT=ierr(6) ) 
     108      ALLOCATE( ub2_b(jpi,jpj), vb2_b(jpi,jpj)                                      , STAT=ierr(5) ) 
    119109#if defined key_agrif 
    120       ALLOCATE( ub2_i_b(jpi,jpj), vb2_i_b(jpi,jpj)                                  , STAT=ierr(7) ) 
     110      ALLOCATE( ub2_i_b(jpi,jpj), vb2_i_b(jpi,jpj)                                  , STAT=ierr(6) ) 
    121111#endif 
    122112         ! 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/step.F90

    r8568 r8586  
    7777      INTEGER ::   ji, jj, jk   ! dummy loop indice 
    7878      INTEGER ::   indic        ! error indicator if < 0 
     79!!gm kcall can be removed, I guess 
    7980      INTEGER ::   kcall        ! optional integer argument (dom_vvl_sf_nxt) 
    8081      !! --------------------------------------------------------------------- 

  • branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/trc_oce.F90

    r7646 r8586  
    2424   PUBLIC   trc_oce_alloc      ! function called by nemogcm.F90 
    2525 
    26    LOGICAL , PUBLIC                                      ::   l_co2cpl  = .false.   !: atmospheric pco2 recieved from oasis 
    27    LOGICAL , PUBLIC                                     ::   l_offline = .false.   !: offline passive tracers flag 
    28    INTEGER , PUBLIC                                      ::   nn_dttrc      !: frequency of step on passive tracers 
    29    REAL(wp), PUBLIC                                      ::   r_si2         !: largest depth of extinction (blue & 0.01 mg.m-3)  (RGB) 
     26   LOGICAL , PUBLIC ::   l_co2cpl  = .false.   !: atmospheric pco2 recieved from oasis 
     27   LOGICAL , PUBLIC ::   l_offline = .false.   !: offline passive tracers flag 
     28   INTEGER , PUBLIC ::   nn_dttrc              !: frequency of step on passive tracers 
     29   REAL(wp), PUBLIC ::   r_si2                 !: largest depth of extinction (blue & 0.01 mg.m-3)  (RGB) 
     30   ! 
    3031   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   etot3         !: light absortion coefficient 
    3132   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   oce_co2   !: ocean carbon flux 
Note: See TracChangeset for help on using the changeset viewer.