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 5620 for branches/2014 – NEMO

Changeset 5620 for branches/2014


Ignore:
Timestamp:
2015-07-21T10:55:28+02:00 (9 years ago)
Author:
jamesharle
Message:

Merge with r5619 of trunk, update to unstructured BDY interpolation in
fldread.F90. Structured BDY interpolation incomplete.

Location:
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC
Files:
155 edited
1 copied

Legend:

Unmodified
Added
Removed
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ASM/asmbkg.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    5757   !!---------------------------------------------------------------------- 
    5858   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    59    !! $Id: $ 
     59   !! $Id$ 
    6060   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    6161   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

    r5038 r5620  
    658658 
    659659      DO jk = 1, jpkm1 
    660          fzptnz(:,:,jk) = eos_fzp( tsn(:,:,jk,jp_sal), fsdept(:,:,jk) ) 
     660        CALL eos_fzp( tsn(:,:,jk,jp_sal), fzptnz(:,:,jk), fsdept(:,:,jk) ) 
    661661      END DO 
    662662 
     
    746746 
    747747 
    748             IF( ln_zps .AND. .NOT. lk_c1d ) & 
    749                &  CALL zps_hde( nit000, jpts, tsb, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    750                &                rhd, gru , grv, aru, arv, gzu, gzv, ge3ru, ge3rv,  &             ! 
    751                &                gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     748            IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav)      & 
     749               &  CALL zps_hde    ( kt, jpts, tsb, gtsu, gtsv,        &  ! Partial steps: before horizontal gradient 
     750               &                              rhd, gru , grv          )  ! of t, s, rd at the last ocean level 
     751            IF( ln_zps .AND. .NOT. lk_c1d .AND.       ln_isfcav)      & 
     752               &  CALL zps_hde_isf( nit000, jpts, tsb, gtsu, gtsv,    &    ! Partial steps for top cell (ISF) 
     753               &                                  rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     754               &                           gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
    752755 
    753756#if defined key_zdfkpp 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_oce.F90

    r4792 r5620  
    4949      LOGICAL                         ::  ll_tem 
    5050      LOGICAL                         ::  ll_sal 
     51      LOGICAL                         ::  ll_fvl 
    5152      REAL(wp), POINTER, DIMENSION(:)     ::  ssh 
    5253      REAL(wp), POINTER, DIMENSION(:)     ::  u2d 
     
    130131   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global        !: workspace for reading in global data arrays (unstr.  bdy) 
    131132   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global_z      !: workspace for reading in global depth arrays (unstr.  bdy) 
     133   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global_dz      !: workspace for reading in global depth arrays (unstr.  bdy) 
    132134   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global2       !: workspace for reading in global data arrays (struct. bdy) 
    133135   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global2_z     !: workspace for reading in global depth arrays (struct. bdy) 
     136   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global2_dz     !: workspace for reading in global depth arrays (struct. bdy) 
    134137!$AGRIF_DO_NOT_TREAT 
    135138   TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET      ::   idx_bdy           !: bdy indices (local process) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r4792 r5620  
    3333   USE ice_2 
    3434#elif defined key_lim3 
    35    USE par_ice 
    3635   USE ice 
    37    USE limcat_1D          ! redistribute ice input into categories 
     36   USE limvar          ! redistribute ice input into categories 
    3837#endif 
    3938   USE sbcapr 
     
    275274 
    276275                        jend = jstart + dta%nread(2) - 1 
    277                         CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend),  & 
    278                                      & kit=jit, kt_offset=time_offset ) 
     276                        IF( ln_full_vel_array(ib_bdy) ) THEN 
     277                           CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend),  & 
     278                                     & kit=jit, kt_offset=time_offset , jpk_bdy=nb_jpk_bdy, fvl=ln_full_vel_array(ib_bdy)  ) 
     279                        ELSE 
     280                           CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend),  & 
     281                                     & kit=jit, kt_offset=time_offset  ) 
     282                        ENDIF 
    279283 
    280284                        ! If full velocities in boundary data then extract barotropic velocities from 3D fields 
     
    341345                     jend = jstart + dta%nread(1) - 1 
    342346                     CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & 
    343                                   & map=nbmap_ptr(jstart:jend), kt_offset=time_offset, jpk_bdy=nb_jpk_bdy ) 
     347                                  & map=nbmap_ptr(jstart:jend), kt_offset=time_offset, jpk_bdy=nb_jpk_bdy, fvl=ln_full_vel_array(ib_bdy) ) 
    344348                  ENDIF 
    345349                  ! If full velocities in boundary data then split into barotropic and baroclinic data 
     
    380384#if defined key_lim3 
    381385               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) 
    382                 CALL lim_cat_1D ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 
     386                CALL lim_var_itd ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 
    383387                                  & dta_bdy(ib_bdy)%ht_i,     dta_bdy(ib_bdy)%ht_s,     dta_bdy(ib_bdy)%a_i     ) 
    384388               ENDIF 
     
    536540            cn_dir_array(ib_bdy) = cn_dir 
    537541            ln_full_vel_array(ib_bdy) = ln_full_vel 
     542            !dta%ll_fvl = ln_full_vel ! jdha need this in fldread routine to work out what type of correction to apply to interpolated bdy data (maybe we replace all instances of ln_full_vel_array with this rather than duplicate) 
    538543 
    539544            nblen => idx_bdy(ib_bdy)%nblen 
     
    734739         IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) ) 
    735740         nbmap_ptr(jfld)%ptr => idx_bdy(ibdy(jfld))%nbmap(:,igrid(jfld)) 
     741         nbmap_ptr(jfld)%ll_unstruc = ln_coords_file(ibdy(jfld)) 
    736742      ENDDO 
    737743 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    3636   !!---------------------------------------------------------------------- 
    3737   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    38    !! $Id: bdydyn.F90 2528 2010-12-27 17:33:53Z rblod $  
     38   !! $Id$  
    3939   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    4040   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn3d.F90

    • Property svn:keywords set to Id
    r4354 r5620  
    3333   !!---------------------------------------------------------------------- 
    3434   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    35    !! $Id: bdydyn.F90 2528 2010-12-27 17:33:53Z rblod $  
     35   !! $Id$  
    3636   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    3737   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    2626   USE dom_ice_2       ! sea-ice domain 
    2727#elif defined key_lim3 
    28    USE par_ice 
    2928   USE ice             ! LIM_3 ice variables 
    3029   USE dom_ice         ! sea-ice domain 
     30   USE limvar 
    3131#endif  
    3232   USE par_oce         ! ocean parameters 
     
    4242   PRIVATE 
    4343 
    44    PUBLIC   bdy_ice_lim    ! routine called in sbcmod 
     44   PUBLIC   bdy_ice_lim     ! routine called in sbcmod 
    4545   PUBLIC   bdy_ice_lim_dyn ! routine called in limrhg 
    4646 
    4747   !!---------------------------------------------------------------------- 
    4848   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    49    !! $Id: bdyice.F90 2715 2011-03-30 15:58:35Z rblod $ 
     49   !! $Id$ 
    5050   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    5151   !!---------------------------------------------------------------------- 
     
    6060      !!---------------------------------------------------------------------- 
    6161      INTEGER, INTENT( in ) :: kt     ! Main time step counter 
    62       !! 
    6362      INTEGER               :: ib_bdy ! Loop index 
     63 
     64#if defined key_lim3 
     65      CALL lim_var_glo2eqv 
     66#endif 
     67 
    6468      DO ib_bdy=1, nb_bdy 
    6569 
     
    7276            CALL ctl_stop( 'bdy_ice_lim : unrecognised option for open boundaries for ice fields' ) 
    7377         END SELECT 
    74       ENDDO 
     78 
     79      END DO 
     80 
     81#if defined key_lim3 
     82      CALL lim_var_zapsmall 
     83      CALL lim_var_agg(1) 
     84#endif 
    7585 
    7686   END SUBROUTINE bdy_ice_lim 
     
    8999      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
    90100      INTEGER,         INTENT(in) ::   kt   ! main time-step counter 
    91       INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index      !! 
     101      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    92102 
    93103      INTEGER  ::   jpbound            ! 0 = incoming ice 
     
    169179            jpbound = 0; ii = ji; ij = jj; 
    170180 
    171             IF ( u_ice(ji+1,jj  ) < 0. .AND. umask(ji-1,jj  ,1) == 0. ) jpbound = 1; ii = ji+1; ij = jj 
    172             IF ( u_ice(ji-1,jj  ) > 0. .AND. umask(ji+1,jj  ,1) == 0. ) jpbound = 1; ii = ji-1; ij = jj 
    173             IF ( v_ice(ji  ,jj+1) < 0. .AND. vmask(ji  ,jj-1,1) == 0. ) jpbound = 1; ii = ji  ; ij = jj+1 
    174             IF ( v_ice(ji  ,jj-1) > 0. .AND. vmask(ji  ,jj+1,1) == 0. ) jpbound = 1; ii = ji  ; ij = jj-1 
    175  
    176             rswitch = 1.0 - MAX( 0.0_wp , SIGN ( 1.0_wp , - at_i(ii,ij) + 0.01 ) ) ! 0 if no ice 
     181            IF( u_ice(ji+1,jj  ) < 0. .AND. umask(ji-1,jj  ,1) == 0. ) jpbound = 1; ii = ji+1; ij = jj 
     182            IF( u_ice(ji-1,jj  ) > 0. .AND. umask(ji+1,jj  ,1) == 0. ) jpbound = 1; ii = ji-1; ij = jj 
     183            IF( v_ice(ji  ,jj+1) < 0. .AND. vmask(ji  ,jj-1,1) == 0. ) jpbound = 1; ii = ji  ; ij = jj+1 
     184            IF( v_ice(ji  ,jj-1) > 0. .AND. vmask(ji  ,jj+1,1) == 0. ) jpbound = 1; ii = ji  ; ij = jj-1 
     185 
     186            IF( nn_ice_lim_dta(ib_bdy) == 0 ) jpbound = 0; ii = ji; ij = jj   ! case ice boundaries = initial conditions 
     187                                                                              !      do not make state variables dependent on velocity 
     188                
     189 
     190            rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ii,ij) - 0.01 ) ) ! 0 if no ice 
    177191 
    178192            ! concentration and thickness 
     
    190204 
    191205               ! Ice salinity, age, temperature 
    192 <<<<<<< .working 
    193                sm_i(ji,jj,jl)   = zinda * rn_ice_sal(ib_bdy)  + ( 1.0 - zinda ) * s_i_min 
    194                o_i(ji,jj,jl)    = zinda * rn_ice_age(ib_bdy)  + ( 1.0 - zinda ) 
    195                t_su(ji,jj,jl)   = zinda * rn_ice_tem(ib_bdy)  + ( 1.0 - zinda ) * rn_ice_tem(ib_bdy) 
    196 ======= 
    197                sm_i(ji,jj,jl)   = rswitch * rn_ice_sal(ib_bdy)  + ( 1.0 - rswitch ) * s_i_min 
    198                o_i(ji,jj,jl)    = rswitch * rn_ice_age(ib_bdy)  + ( 1.0 - rswitch ) 
     206               sm_i(ji,jj,jl)   = rswitch * rn_ice_sal(ib_bdy)  + ( 1.0 - rswitch ) * rn_simin 
     207               oa_i(ji,jj,jl)   = rswitch * rn_ice_age(ib_bdy) * a_i(ji,jj,jl) 
    199208               t_su(ji,jj,jl)   = rswitch * rn_ice_tem(ib_bdy)  + ( 1.0 - rswitch ) * rn_ice_tem(ib_bdy) 
    200 >>>>>>> .merge-right.r5035 
    201209               DO jk = 1, nlay_s 
    202 <<<<<<< .working 
    203                   t_s(ji,jj,jk,jl) = zinda * rn_ice_tem(ib_bdy) + ( 1.0 - zinda ) * rtt 
    204 ======= 
    205                   t_s(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rtt 
    206 >>>>>>> .merge-right.r5035 
     210                  t_s(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rt0 
    207211               END DO 
    208212               DO jk = 1, nlay_i 
    209 <<<<<<< .working 
    210                   t_i(ji,jj,jk,jl) = zinda * rn_ice_tem(ib_bdy) + ( 1.0 - zinda ) * rtt  
    211                   s_i(ji,jj,jk,jl) = zinda * rn_ice_sal(ib_bdy) + ( 1.0 - zinda ) * s_i_min 
    212 ======= 
    213                   t_i(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rtt  
    214                   s_i(ji,jj,jk,jl) = rswitch * rn_ice_sal(ib_bdy) + ( 1.0 - rswitch ) * s_i_min 
    215 >>>>>>> .merge-right.r5035 
     213                  t_i(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rt0  
     214                  s_i(ji,jj,jk,jl) = rswitch * rn_ice_sal(ib_bdy) + ( 1.0 - rswitch ) * rn_simin 
    216215               END DO 
    217216                
     
    219218  
    220219               ! Ice salinity, age, temperature 
    221                sm_i(ji,jj,jl)   = rswitch * sm_i(ii,ij,jl)  + ( 1.0 - rswitch ) * s_i_min 
    222                o_i(ji,jj,jl)    = rswitch * o_i(ii,ij,jl)   + ( 1.0 - rswitch ) 
    223                t_su(ji,jj,jl)   = rswitch * t_su(ii,ij,jl)  + ( 1.0 - rswitch ) * rtt 
     220               sm_i(ji,jj,jl)   = rswitch * sm_i(ii,ij,jl)  + ( 1.0 - rswitch ) * rn_simin 
     221               oa_i(ji,jj,jl)   = rswitch * oa_i(ii,ij,jl) 
     222               t_su(ji,jj,jl)   = rswitch * t_su(ii,ij,jl)  + ( 1.0 - rswitch ) * rt0 
    224223               DO jk = 1, nlay_s 
    225                   t_s(ji,jj,jk,jl) = rswitch * t_s(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rtt 
     224                  t_s(ji,jj,jk,jl) = rswitch * t_s(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rt0 
    226225               END DO 
    227226               DO jk = 1, nlay_i 
    228                   t_i(ji,jj,jk,jl) = rswitch * t_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rtt 
    229                   s_i(ji,jj,jk,jl) = rswitch * s_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * s_i_min 
     227                  t_i(ji,jj,jk,jl) = rswitch * t_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rt0 
     228                  s_i(ji,jj,jk,jl) = rswitch * s_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rn_simin 
    230229               END DO 
    231230 
     
    233232 
    234233            ! if salinity is constant, then overwrite rn_ice_sal 
    235             IF( num_sal == 1 ) THEN 
    236                sm_i(ji,jj,jl)   = bulk_sal 
    237                s_i (ji,jj,:,jl) = bulk_sal 
     234            IF( nn_icesal == 1 ) THEN 
     235               sm_i(ji,jj,jl)   = rn_icesal 
     236               s_i (ji,jj,:,jl) = rn_icesal 
    238237            ENDIF 
    239238 
    240239            ! contents 
    241240            smv_i(ji,jj,jl)  = MIN( sm_i(ji,jj,jl) , sss_m(ji,jj) ) * v_i(ji,jj,jl) 
    242             oa_i(ji,jj,jl)   = o_i(ji,jj,jl) * a_i(ji,jj,jl) 
    243241            DO jk = 1, nlay_s 
    244242               ! Snow energy of melting 
    245                e_s(ji,jj,jk,jl) = rswitch * rhosn * ( cpic * ( rtt - t_s(ji,jj,jk,jl) ) + lfus ) 
    246                ! Change dimensions 
    247                e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) / unit_fac 
    248                ! Multiply by volume, so that heat content in 10^9 Joules 
    249                e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * area(ji,jj) * v_s(ji,jj,jl) / nlay_s 
     243               e_s(ji,jj,jk,jl) = rswitch * rhosn * ( cpic * ( rt0 - t_s(ji,jj,jk,jl) ) + lfus ) 
     244               ! Multiply by volume, so that heat content in J/m2 
     245               e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * v_s(ji,jj,jl) * r1_nlay_s 
    250246            END DO 
    251247            DO jk = 1, nlay_i 
    252                ztmelts          = - tmut * s_i(ji,jj,jk,jl) + rtt !Melting temperature in K                   
     248               ztmelts          = - tmut * s_i(ji,jj,jk,jl) + rt0 !Melting temperature in K                   
    253249               ! heat content per unit volume 
    254250               e_i(ji,jj,jk,jl) = rswitch * rhoic * & 
    255251                  (   cpic    * ( ztmelts - t_i(ji,jj,jk,jl) ) & 
    256                   +   lfus    * ( 1.0 - (ztmelts-rtt) / MIN((t_i(ji,jj,jk,jl)-rtt),-epsi20) ) & 
    257                   - rcp      * ( ztmelts - rtt ) ) 
    258                ! Correct dimensions to avoid big values 
    259                e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / unit_fac  
    260                ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J 
    261                e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * area(ji,jj) * a_i(ji,jj,jl) * ht_i(ji,jj,jl) / nlay_i 
     252                  +   lfus    * ( 1.0 - (ztmelts-rt0) / MIN((t_i(ji,jj,jk,jl)-rt0),-epsi20) ) & 
     253                  - rcp      * ( ztmelts - rt0 ) ) 
     254               ! Mutliply by ice volume, and divide by number of layers to get heat content in J/m2 
     255               e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * a_i(ji,jj,jl) * ht_i(ji,jj,jl) * r1_nlay_i 
    262256            END DO 
    263257 
    264  
    265          END DO !jb 
     258         END DO 
    266259  
    267          CALL lbc_bdy_lnk(  a_i(:,:,jl), 'T', 1., ib_bdy )                                         ! lateral boundary conditions 
     260         CALL lbc_bdy_lnk(  a_i(:,:,jl), 'T', 1., ib_bdy ) 
    268261         CALL lbc_bdy_lnk( ht_i(:,:,jl), 'T', 1., ib_bdy ) 
    269262         CALL lbc_bdy_lnk( ht_s(:,:,jl), 'T', 1., ib_bdy ) 
     
    274267         CALL lbc_bdy_lnk(  sm_i(:,:,jl), 'T', 1., ib_bdy ) 
    275268         CALL lbc_bdy_lnk(  oa_i(:,:,jl), 'T', 1., ib_bdy ) 
    276          CALL lbc_bdy_lnk(   o_i(:,:,jl), 'T', 1., ib_bdy ) 
    277269         CALL lbc_bdy_lnk(  t_su(:,:,jl), 'T', 1., ib_bdy ) 
    278270         DO jk = 1, nlay_s 
     
    306298      !! 
    307299      CHARACTER(len=1), INTENT(in)  ::   cd_type   ! nature of velocity grid-points 
    308       INTEGER  ::   jb, jgrd   ! dummy loop indices 
     300      INTEGER  ::   jb, jgrd           ! dummy loop indices 
    309301      INTEGER  ::   ji, jj             ! local scalar 
    310       INTEGER  ::   ib_bdy ! Loop index 
     302      INTEGER  ::   ib_bdy             ! Loop index 
    311303      REAL(wp) ::   zmsk1, zmsk2, zflag 
    312304     !!------------------------------------------------------------------------------ 
     
    324316         CASE('frs') 
    325317             
    326  
     318            IF( nn_ice_lim_dta(ib_bdy) == 0 ) CYCLE            ! case ice boundaries = initial conditions  
     319                                                               !      do not change ice velocity (it is only computed by rheology) 
     320  
    327321            SELECT CASE ( cd_type ) 
    328  
     322                
    329323            CASE ( 'U' ) 
    330324                
     
    341335                      
    342336                     ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then u_ice = u_oce) 
    343                      u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5 * ABS( zflag + 1._wp ) * zmsk1 + & 
    344                         &            u_ice(ji-1,jj) * 0.5 * ABS( zflag - 1._wp ) * zmsk2 + & 
     337                     u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 
     338                        &            u_ice(ji-1,jj) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 
    345339                        &            u_oce(ji  ,jj) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 
    346340                  ELSE                             ! everywhere else 
     
    349343                  ENDIF 
    350344                  ! mask ice velocities 
    351                   rswitch = 1.0 - MAX( 0.0_wp , SIGN ( 1.0_wp , - at_i(ji,jj) + 0.01 ) ) ! 0 if no ice 
     345                  rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ji,jj) - 0.01_wp ) ) ! 0 if no ice 
    352346                  u_ice(ji,jj) = rswitch * u_ice(ji,jj) 
    353347                   
    354348               ENDDO 
    355  
     349                
    356350               CALL lbc_bdy_lnk( u_ice(:,:), 'U', -1., ib_bdy ) 
    357351                
     
    370364                      
    371365                     ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then u_ice = u_oce) 
    372                      v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5 * ABS( zflag + 1._wp ) * zmsk1 + & 
    373                         &            v_ice(ji,jj-1) * 0.5 * ABS( zflag - 1._wp ) * zmsk2 + & 
     366                     v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 
     367                        &            v_ice(ji,jj-1) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 
    374368                        &            v_oce(ji,jj  ) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 
    375369                  ELSE                             ! everywhere else 
     
    378372                  ENDIF 
    379373                  ! mask ice velocities 
    380                   rswitch = 1.0 - MAX( 0.0_wp , SIGN ( 1.0_wp , - at_i(ji,jj) + 0.01 ) ) ! 0 if no ice 
     374                  rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ji,jj) - 0.01 ) ) ! 0 if no ice 
    381375                  v_ice(ji,jj) = rswitch * v_ice(ji,jj) 
    382376                   
     
    384378                
    385379               CALL lbc_bdy_lnk( v_ice(:,:), 'V', -1., ib_bdy ) 
    386                 
     380                   
    387381            END SELECT 
    388382             
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r5038 r5620  
    155155        ENDIF 
    156156        IF(lwp) WRITE(numout,*) 
    157  
     157         
    158158        IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution:  ' 
    159159        SELECT CASE( cn_dyn2d(ib_bdy) )                   
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdylib.F90

    • Property svn:keywords set to Id
    r4292 r5620  
    2929   !!---------------------------------------------------------------------- 
    3030   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    31    !! $Id: bdydyn.F90 2528 2010-12-27 17:33:53Z rblod $  
     31   !! $Id$  
    3232   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    3333   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

    r4792 r5620  
    3232   USE tideini 
    3333!   USE tide_mod       ! Useless ?? 
    34    USE fldread, ONLY: fld_map 
     34   USE fldread 
    3535   USE dynspg_oce, ONLY: lk_dynspg_ts 
    3636 
     
    8888      !! 
    8989      TYPE(TIDES_DATA),  POINTER                ::   td                  !: local short cut    
     90      TYPE(MAP_POINTER), DIMENSION(jpbgrd)      ::   ibmap_ptr           !: array of pointers to nbmap 
    9091      !! 
    9192      NAMELIST/nambdy_tide/filtide, ln_bdytide_2ddta, ln_bdytide_conj 
     
    125126            IF(lwp) WRITE(numout,*) '             Number of tidal components to read: ', nb_harmo 
    126127            IF(lwp) THEN  
    127                     WRITE(numout,*) '             Tidal cpt name    -     Phase speed (deg/hr)'             
     128                    WRITE(numout,*) '             Tidal components: '  
    128129               DO itide = 1, nb_harmo 
    129                   WRITE(numout,*)  '             ', Wave(ntide(itide))%cname_tide, omega_tide(itide)   
     130                  WRITE(numout,*)  '                 ', Wave(ntide(itide))%cname_tide  
    130131               END DO 
    131132            ENDIF  
     
    220221               !  
    221222               ALLOCATE( dta_read( MAXVAL(ilen0(1:3)), 1, 1 ) ) 
     223               ! 
     224               ! Set map structure 
     225               ibmap_ptr(1)%ptr => idx_bdy(ib_bdy)%nbmap(:,1) 
     226               ibmap_ptr(1)%ll_unstruc = ln_coords_file(ib_bdy) 
     227               ibmap_ptr(2)%ptr => idx_bdy(ib_bdy)%nbmap(:,2) 
     228               ibmap_ptr(2)%ll_unstruc = ln_coords_file(ib_bdy) 
     229               ibmap_ptr(3)%ptr => idx_bdy(ib_bdy)%nbmap(:,3) 
     230               ibmap_ptr(3)%ll_unstruc = ln_coords_file(ib_bdy) 
    222231 
    223232               ! Open files and read in tidal forcing data 
     
    228237                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_T.nc' 
    229238                  CALL iom_open( clfile, inum ) 
    230                   CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) 
     239                  CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1,  ibmap_ptr(1) ) 
    231240                  td%ssh0(:,itide,1) = dta_read(1:ilen0(1),1,1) 
    232                   CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) 
     241                  CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1,  ibmap_ptr(1) ) 
    233242                  td%ssh0(:,itide,2) = dta_read(1:ilen0(1),1,1) 
    234243                  CALL iom_close( inum ) 
     
    236245                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_U.nc' 
    237246                  CALL iom_open( clfile, inum ) 
    238                   CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) 
     247                  CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, ibmap_ptr(2) ) 
    239248                  td%u0(:,itide,1) = dta_read(1:ilen0(2),1,1) 
    240                   CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) 
     249                  CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, ibmap_ptr(2) ) 
    241250                  td%u0(:,itide,2) = dta_read(1:ilen0(2),1,1) 
    242251                  CALL iom_close( inum ) 
     
    244253                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_V.nc' 
    245254                  CALL iom_open( clfile, inum ) 
    246                   CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) 
     255                  CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, ibmap_ptr(3) ) 
    247256                  td%v0(:,itide,1) = dta_read(1:ilen0(3),1,1) 
    248                   CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) 
     257                  CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, ibmap_ptr(3) ) 
    249258                  td%v0(:,itide,2) = dta_read(1:ilen0(3),1,1) 
    250259                  CALL iom_close( inum ) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/c1d.F90

    • Property svn:keywords set to Id
    r4792 r5620  
    3131   !!---------------------------------------------------------------------- 
    3232   !! NEMO/C1D 3.3 , NEMO Consortium (2010) 
    33    !! $Id: c1d.F90 2382 2010-11-13 13:08:12Z gm $  
     33   !! $Id$  
    3434   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3535   !!====================================================================== 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/domc1d.F90

    • Property svn:keywords set to Id
    r4792 r5620  
    2626   !!---------------------------------------------------------------------- 
    2727   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    28    !! $Id: domc1d.F90 3851 2013-04-30 10:30:51Z hadcv $  
     28   !! $Id$  
    2929   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3030   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/dtauvd.F90

    • Property svn:keywords set to Id
    r4792 r5620  
    3535   !!---------------------------------------------------------------------- 
    3636   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    37    !! $Id: dtauvd.F90 2392 2010-11-15 21:20:05Z gm $  
     37   !! $Id$  
    3838   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3939   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/dyncor_c1d.F90

    • Property svn:keywords set to Id
    r2409 r5620  
    3030   !!---------------------------------------------------------------------- 
    3131   !! NEMO/C1D 3.3 , NEMO Consortium (2010) 
    32    !! $Id: dyncor_c1d.F90 2382 2010-11-13 13:08:12Z gm $  
     32   !! $Id$  
    3333   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3434   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/dyndmp.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    33   !!                       ***  MODULE  dyndmp  *** 
    44   !! Ocean dynamics: internal restoring trend on momentum (U and V current) 
     5   !!                 This should only be used for C1D case in current form 
    56   !!====================================================================== 
    67   !! History :  3.5  ! 2013-08  (D. Calvert)  Original code 
     8   !!            3.6  ! 2014-08  (T. Graham) Modified to use netcdf file of 
     9   !!                             restoration coefficients supplied to tradmp 
    710   !!---------------------------------------------------------------------- 
    811 
     
    2528   USE wrk_nemo       ! Memory allocation 
    2629   USE timing         ! Timing 
     30   USE iom            ! I/O manager 
    2731 
    2832   IMPLICIT NONE 
     
    4347   !!---------------------------------------------------------------------- 
    4448   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    45    !! $Id: dyndmp.F90 3294 2012-01-28 16:44:18Z rblod $  
     49   !! $Id$  
    4650   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4751   !!---------------------------------------------------------------------- 
     
    7377      NAMELIST/namc1d_dyndmp/ ln_dyndmp 
    7478      INTEGER :: ios 
     79      INTEGER :: imask 
    7580      !!---------------------------------------------------------------------- 
    7681 
     
    9196         WRITE(numout,*) '      add a damping term or not       ln_dyndmp = ', ln_dyndmp 
    9297         WRITE(numout,*) '   Namelist namtra_dmp    : Set damping parameters' 
    93          WRITE(numout,*) '      horizontal damping option       nn_hdmp   = ', nn_hdmp 
    94          WRITE(numout,*) '      mixed layer damping option      nn_zdmp   = ', nn_zdmp, '(non-C1D zoom: forced to 0)' 
    95          WRITE(numout,*) '      surface time scale (days)       rn_surf   = ', rn_surf 
    96          WRITE(numout,*) '      bottom time scale (days)        rn_bot    = ', rn_bot 
    97          WRITE(numout,*) '      depth of transition (meters)    rn_dep    = ', rn_dep 
    98          WRITE(numout,*) '      create a damping.coeff file     nn_file   = ', nn_file 
     98         WRITE(numout,*) '      Apply relaxation   or not       ln_tradmp = ', ln_tradmp 
     99         WRITE(numout,*) '      mixed layer damping option      nn_zdmp   = ', nn_zdmp 
     100         WRITE(numout,*) '      Damping file name               cn_resto  = ', cn_resto 
    99101         WRITE(numout,*) 
    100102      ENDIF 
     
    104106         IF( dyn_dmp_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dyn_dmp_init: unable to allocate arrays' ) 
    105107         ! 
    106 #if ! defined key_c1d 
    107          SELECT CASE ( nn_hdmp )             !==   control print of horizontal option   ==! 
    108          CASE (  -1  )   ;   IF(lwp) WRITE(numout,*) '   momentum damping in the Med & Red seas only' 
    109          CASE ( 1:90 )   ;   IF(lwp) WRITE(numout,*) '   momentum damping poleward of', nn_hdmp, ' degrees' 
    110          CASE DEFAULT 
    111             WRITE(ctmp1,*) '          bad flag value for nn_hdmp = ', nn_hdmp 
    112             CALL ctl_stop(ctmp1) 
    113          END SELECT 
    114          ! 
    115 #endif 
    116108         SELECT CASE ( nn_zdmp )             !==   control print of vertical option   ==! 
    117109         CASE ( 0    )   ;   IF(lwp) WRITE(numout,*) '   momentum damping throughout the water column' 
     
    130122         utrdmp(:,:,:) = 0._wp               ! internal damping trends 
    131123         vtrdmp(:,:,:) = 0._wp 
    132          !                                   !==   Damping coefficients calculation:                           ==! 
    133          !                                   !==   use tradmp.F90 subroutines dtacof, dtacof_zoom and cofdis   ==! 
    134          !                                   !!!   NOTE: these need to be altered for use in this module if  
    135          !                                   !!!       they are to be used outside the C1D context  
    136          !                                   !!!       (use of U,V grid variables) 
    137          IF( lzoom .AND. .NOT. lk_c1d ) THEN   ;   CALL dtacof_zoom( resto_uv ) 
    138          ELSE               ;   CALL dtacof( nn_hdmp, rn_surf, rn_bot, rn_dep, nn_file, 'DYN', resto_uv ) 
    139          ENDIF 
    140          ! 
     124         ! 
     125         !Read in mask from file 
     126         CALL iom_open ( cn_resto, imask) 
     127         CALL iom_get  ( imask, jpdom_autoglo, 'resto', resto) 
     128         CALL iom_close( imask ) 
    141129      ENDIF 
    142130      ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/dynnxt_c1d.F90

    • Property svn:keywords set to Id
    r2409 r5620  
    2525   !!---------------------------------------------------------------------- 
    2626   !! NEMO/C1D 3.3 , NEMO Consortium (2010) 
    27    !! $Id: dynnxt_c1d.F90 2382 2010-11-13 13:08:12Z gm $  
     27   !! $Id$  
    2828   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    2929   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/step_c1d.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    3232   !!---------------------------------------------------------------------- 
    3333   !! NEMO/C1D 3.3 , NEMO Consortium (2010) 
    34    !! $Id: step_c1d.F90 2382 2010-11-13 13:08:12Z gm $ 
     34   !! $Id$ 
    3535   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3636   !!---------------------------------------------------------------------- 
     
    7272      ! Ocean physics update                (ua, va, ta, sa used as workspace) 
    7373      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     74                         CALL eos_rab( tsb, rab_b )   ! before local thermal/haline expension ratio at T-points 
     75                         CALL eos_rab( tsn, rab_n )   ! now    local thermal/haline expension ratio at T-points 
    7476                         CALL bn2( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency 
    7577                         CALL bn2( tsn, rab_n, rn2  ) ! now    Brunt-Vaisala frequency 
     
    132134                        CALL tra_nxt( kstp )       ! tracer fields at next time step 
    133135 
     136 
     137 
    134138      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    135139      ! Dynamics                                    (ta, sa used as workspace) 
     
    150154      IF( lrst_oce       )   CALL rst_write( kstp )        ! write output ocean restart file 
    151155      ! 
     156#if defined key_iomput 
     157      IF( kstp == nitend .OR. indic < 0 )   CALL xios_context_finalize()   ! needed for XIOS 
     158      ! 
     159#endif 
    152160   END SUBROUTINE stp_c1d 
    153161 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90

    • Property svn:keywords set to Id
    r4064 r5620  
    164164 
    165165 
     166   !! $Id$ 
    166167CONTAINS 
    167168    
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90

    • Property svn:keywords set to Id
    r4314 r5620  
    5757#  include "domzgr_substitute.h90" 
    5858    
     59   !! $Id$ 
    5960CONTAINS 
    6061 
     
    18821883      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) 
    18831884 
    1884       CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 
     1885      CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk, zsurf ) 
    18851886 
    18861887   END SUBROUTINE crs_dom_sfc 
     
    22742275      ENDDO 
    22752276      
    2276       CALL wrk_alloc( jpi_crs, jpj_crs, zmbk ) 
    2277  
    22782277      zmbk(:,:) = 0.0 
    22792278      zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ;   CALL crs_lbc_lnk(zmbk,'T',1.0)   ;   mbathy_crs(:,:) = INT( zmbk(:,:) ) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crsdomwri.F90

    • Property svn:keywords set to Id
    r4294 r5620  
    3333   PUBLIC crs_dom_wri        ! routine called by crsini.F90 
    3434 
     35   !! $Id$ 
    3536CONTAINS 
    3637 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90

    • Property svn:keywords set to Id
    r4149 r5620  
    3838   !!---------------------------------------------------------------------- 
    3939   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    40    !! $Id $ 
     40   !! $Id$ 
    4141   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4242   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90

    • Property svn:keywords set to Id
    r4792 r5620  
    2929#  include "domzgr_substitute.h90" 
    3030 
     31   !! $Id$ 
    3132CONTAINS 
    3233    
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90

    • Property svn:keywords set to Id
    r4015 r5620  
    2222   PUBLIC crs_lbc_lnk 
    2323    
     24   !! $Id$ 
    2425CONTAINS 
    2526 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r5038 r5620  
    2121   USE timing         ! preformance summary 
    2222   USE wrk_nemo       ! working arrays 
     23   USE fldread        ! type FLD_N 
     24   USE phycst         ! physical constant 
     25   USE in_out_manager  ! I/O manager 
    2326 
    2427   IMPLICIT NONE 
     
    8386      CALL wrk_alloc( jpi , jpj , jpk , jpts , ztsn                 ) 
    8487 
    85       CALL iom_put( 'cellthc', fse3t(:,:,:) ) 
    86  
    8788      zarea_ssh(:,:) = area(:,:) * sshn(:,:) 
    8889 
     
    105106      END DO 
    106107      IF( .NOT.lk_vvl ) THEN 
    107          DO ji=1,jpi 
    108             DO jj=1,jpj 
    109                zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 
    110             END DO 
    111          END DO 
     108         IF ( ln_isfcav ) THEN 
     109            DO ji=1,jpi 
     110               DO jj=1,jpj 
     111                  zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 
     112               END DO 
     113            END DO 
     114         ELSE 
     115            zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 
     116         END IF 
    112117      END IF 
    113118      !                                          
     
    127132      END DO 
    128133      IF( .NOT.lk_vvl ) THEN 
    129          DO ji=1,jpi 
    130             DO jj=1,jpj 
    131                zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 
    132             END DO 
    133          END DO 
     134         IF ( ln_isfcav ) THEN 
     135            DO ji=1,jpi 
     136               DO jj=1,jpj 
     137                  zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 
     138               END DO 
     139            END DO 
     140         ELSE 
     141            zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 
     142         END IF 
    134143      END IF 
    135144      !     
     
    157166      END DO 
    158167      IF( .NOT.lk_vvl ) THEN 
    159          DO ji=1,jpi 
    160             DO jj=1,jpj 
    161                ztemp = ztemp + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_tem)  
    162                zsal  = zsal  + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_sal)  
    163             END DO 
    164          END DO 
     168         IF ( ln_isfcav ) THEN 
     169            DO ji=1,jpi 
     170               DO jj=1,jpj 
     171                  ztemp = ztemp + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_tem)  
     172                  zsal  = zsal  + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_sal)  
     173               END DO 
     174            END DO 
     175         ELSE 
     176            ztemp = ztemp + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_tem) ) 
     177            zsal  = zsal  + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_sal) ) 
     178         END IF 
    165179      ENDIF 
    166180      IF( lk_mpp ) THEN   
     
    197211      REAL(wp) ::   zztmp   
    198212      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zsaldta   ! Jan/Dec levitus salinity 
     213      ! reading initial file 
     214      LOGICAL  ::   ln_tsd_init      !: T & S data flag 
     215      LOGICAL  ::   ln_tsd_tradmp    !: internal damping toward input data flag 
     216      CHARACTER(len=100)            ::   cn_dir 
     217      TYPE(FLD_N)                   ::  sn_tem,sn_sal 
     218      INTEGER  ::   ios=0 
     219 
     220      NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal 
     221      ! 
     222 
     223      REWIND( numnam_ref )              ! Namelist namtsd in reference namelist : 
     224      READ  ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 
     225901   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp ) 
     226      REWIND( numnam_cfg )              ! Namelist namtsd in configuration namelist : Parameters of the run 
     227      READ  ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 
     228902   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp ) 
     229      IF(lwm) WRITE ( numond, namtsd ) 
     230      ! 
    199231      !!---------------------------------------------------------------------- 
    200232      ! 
     
    216248      END DO 
    217249      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    218        
    219       CALL iom_open ( 'data_1m_salinity_nomask', inum ) 
    220       CALL iom_get  ( inum, jpdom_data, 'vosaline', zsaldta(:,:,:,1), 1  ) 
    221       CALL iom_get  ( inum, jpdom_data, 'vosaline', zsaldta(:,:,:,2), 12 ) 
     250 
     251      CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 
     252      CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1  ) 
     253      CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 
    222254      CALL iom_close( inum ) 
    223255      sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diadct.F90

    • Property svn:keywords set to Id
    r4792 r5620  
    4242#endif 
    4343#if defined key_lim3 
    44   USE par_ice 
    4544  USE ice 
    4645#endif 
     
    113112  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::  transports_2d   
    114113 
     114   !! $Id$ 
    115115CONTAINS 
    116116 
     
    176176 
    177177     !open output file 
    178      IF( lwp ) THEN 
     178     IF( lwm ) THEN 
    179179        CALL ctl_opn( numdct_vol,  'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
    180180        CALL ctl_opn( numdct_heat, 'heat_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
     
    283283           DO jsec=1,nb_sec 
    284284 
    285               IF( lwp )CALL dia_dct_wri(kt,jsec,secs(jsec)) 
     285              IF( lwm )CALL dia_dct_wri(kt,jsec,secs(jsec)) 
    286286             
    287287              !nullify transports values after writing 
     
    12981298   LOGICAL, PUBLIC, PARAMETER ::   lk_diadct = .FALSE.    !: diamht flag 
    12991299   PUBLIC  
     1300   !! $Id$ 
    13001301CONTAINS 
    13011302 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diafwb.F90

    r5038 r5620  
    5151      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    5252      !! 
    53       INTEGER :: inum             ! temporary logical unit 
    54       INTEGER :: ji, jj, jk, jt   ! dummy loop indices 
    55       INTEGER :: ii0, ii1, ij0, ij1 
    56       REAL(wp) ::   zarea, zvol, zwei 
    57       REAL(wp) ::  ztemi(4), ztemo(4), zsali(4), zsalo(4), zflxi(4), zflxo(4) 
    58       REAL(wp) ::  zt, zs, zu   
    59       REAL(wp) ::  zsm0, zfwfnew 
     53      INTEGER  :: inum             ! temporary logical unit 
     54      INTEGER  :: ji, jj, jk, jt   ! dummy loop indices 
     55      INTEGER  :: ii0, ii1, ij0, ij1 
     56      INTEGER  :: isrow         ! index for ORCA1 starting row 
     57      REAL(wp) :: zarea, zvol, zwei 
     58      REAL(wp) :: ztemi(4), ztemo(4), zsali(4), zsalo(4), zflxi(4), zflxo(4) 
     59      REAL(wp) :: zt, zs, zu   
     60      REAL(wp) :: zsm0, zfwfnew 
    6061      IF( cp_cfg == "orca" .AND. jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN 
    6162      !!---------------------------------------------------------------------- 
     
    165166         CASE ( 1 )                                  !  ORCA_R1 configurations 
    166167            !                                        ! ======================= 
    167             ii0 = 283   ;   ii1 = 283 
    168             ij0 = 200   ;   ij1 = 200 
     168            ! This dirty section will be suppressed by simplification process: 
     169            ! all this will come back in input files 
     170            ! Currently these hard-wired indices relate to configuration with 
     171            ! extend grid (jpjglo=332) 
     172            isrow = 332 - jpjglo 
     173            ! 
     174            ii0 = 283           ;   ii1 = 283 
     175            ij0 = 241 - isrow   ;   ij1 = 241 - isrow 
    169176            !                                        ! ======================= 
    170177         CASE DEFAULT                                !    ORCA R05 or R025 
     
    212219         CASE ( 1 )                                  !  ORCA_R1 configurations 
    213220            !                                        ! ======================= 
    214             ii0 = 282   ;   ii1 = 282 
    215             ij0 = 200   ;   ij1 = 200 
     221            ! This dirty section will be suppressed by simplification process: 
     222            ! all this will come back in input files 
     223            ! Currently these hard-wired indices relate to configuration with 
     224            ! extend grid (jpjglo=332) 
     225            isrow = 332 - jpjglo 
     226            ii0 = 282           ;   ii1 = 282 
     227            ij0 = 240 - isrow   ;   ij1 = 240 - isrow 
    216228            !                                        ! ======================= 
    217229         CASE DEFAULT                                !    ORCA R05 or R025 
     
    259271         CASE ( 1 )                                  !  ORCA_R1 configurations 
    260272            !                                        ! ======================= 
    261             ii0 = 331   ;   ii1 = 331 
    262             ij0 = 176   ;   ij1 = 176 
     273            ! This dirty section will be suppressed by simplification process: 
     274            ! all this will come back in input files 
     275            ! Currently these hard-wired indices relate to configuration with 
     276            ! extend grid (jpjglo=332) 
     277            isrow = 332 - jpjglo 
     278            ii0 = 331           ;   ii1 = 331 
     279            ij0 = 215 - isrow   ;   ij1 = 215 - isrow 
    263280            !                                        ! ======================= 
    264281         CASE DEFAULT                                !    ORCA R05 or R025 
     
    306323         CASE ( 1 )                                  !  ORCA_R1 configurations 
    307324            !                                        ! ======================= 
    308             ii0 = 297   ;   ii1 = 297  
    309             ij0 = 230   ;   ij1 = 230 
     325            ! This dirty section will be suppressed by simplification process: 
     326            ! all this will come back in input files 
     327            ! Currently these hard-wired indices relate to configuration with 
     328            ! extend grid (jpjglo=332) 
     329            isrow = 332 - jpjglo 
     330            ii0 = 297           ;   ii1 = 297 
     331            ij0 = 269 - isrow   ;   ij1 = 269 - isrow 
    310332            !                                        ! ======================= 
    311333         CASE DEFAULT                                !    ORCA R05 or R025 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    6060   !!---------------------------------------------------------------------- 
    6161   !! NEMO/OPA 3.5 , NEMO Consortium (2013) 
    62    !! $Id:$ 
     62   !! $Id$ 
    6363   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    6464   !!---------------------------------------------------------------------- 
     
    196196                  DO ji = 1,jpi 
    197197                     ! Elevation 
    198                      ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)           *tmask_i(ji,jj)         
    199 #if defined key_dynspg_ts 
    200                      ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*hur(ji,jj)*umask_i(ji,jj) 
    201                      ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask_i(ji,jj) 
    202 #endif 
     198                     ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*tmask_i(ji,jj)         
     199                     ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*umask_i(ji,jj) 
     200                     ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*vmask_i(ji,jj) 
    203201                  END DO 
    204202               END DO 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r5038 r5620  
    9696      z_frc_trd_t =           glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) )                               ! heat fluxes 
    9797      z_frc_trd_s =           glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) )                               ! salt fluxes 
    98       ! Add runoff heat & salt input 
     98      ! Add runoff    heat & salt input 
    9999      IF( ln_rnf    )   z_frc_trd_t = z_frc_trd_t + glob_sum( rnf_tsc(:,:,jp_tem) * surf(:,:) ) 
    100100      IF( ln_rnf_sal)   z_frc_trd_s = z_frc_trd_s + glob_sum( rnf_tsc(:,:,jp_sal) * surf(:,:) ) 
    101       ! Add geothermal ice shelf 
     101      ! Add ice shelf heat & salt input 
    102102      IF( nn_isf .GE. 1 )  THEN 
    103103          z_frc_trd_t = z_frc_trd_t & 
     
    112112      ! 
    113113      IF( .NOT. lk_vvl ) THEN 
    114          z2d0=0.0_wp ; z2d1=0.0_wp 
    115          DO ji=1,jpi 
    116             DO jj=1,jpj 
    117               z2d0(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_tem) 
    118               z2d1(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_sal) 
     114         IF ( ln_isfcav ) THEN 
     115            DO ji=1,jpi 
     116               DO jj=1,jpj 
     117                  z2d0(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_tem) 
     118                  z2d1(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_sal) 
     119               ENDDO 
    119120            ENDDO 
    120          ENDDO 
     121         ELSE 
     122            z2d0(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_tem) 
     123            z2d1(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_sal) 
     124         END IF 
    121125         z_wn_trd_t = - glob_sum( z2d0 )  
    122126         z_wn_trd_s = - glob_sum( z2d1 ) 
     
    144148      ! heat & salt content variation (associated with ssh) 
    145149      IF( .NOT. lk_vvl ) THEN 
    146          z2d0 = 0._wp   ;   z2d1 = 0._wp 
    147          DO ji = 1, jpi 
    148             DO jj = 1, jpj 
    149               z2d0(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) - ssh_hc_loc_ini(ji,jj) )  
    150               z2d1(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) - ssh_sc_loc_ini(ji,jj) )  
     150         IF ( ln_isfcav ) THEN 
     151            DO ji = 1, jpi 
     152               DO jj = 1, jpj 
     153                  z2d0(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) - ssh_hc_loc_ini(ji,jj) )  
     154                  z2d1(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) - ssh_sc_loc_ini(ji,jj) )  
     155               END DO 
    151156            END DO 
    152          END DO 
     157         ELSE 
     158            z2d0(:,:) = surf(:,:) * ( tsn(:,:,1,jp_tem) * sshn(:,:) - ssh_hc_loc_ini(:,:) )  
     159            z2d1(:,:) = surf(:,:) * ( tsn(:,:,1,jp_sal) * sshn(:,:) - ssh_sc_loc_ini(:,:) )  
     160         END IF 
    153161         z_ssh_hc = glob_sum( z2d0 )  
    154162         z_ssh_sc = glob_sum( z2d1 )  
     
    277285          frc_s = 0._wp                                           ! salt content   -    -   -    -         
    278286          IF( .NOT. lk_vvl ) THEN 
    279              DO ji=1,jpi 
    280                 DO jj=1,jpj 
    281                    ssh_hc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj)   ! initial heat content in ssh 
    282                    ssh_sc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj)   ! initial salt content in ssh 
     287             IF ( ln_isfcav ) THEN 
     288                DO ji=1,jpi 
     289                   DO jj=1,jpj 
     290                      ssh_hc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj)   ! initial heat content in ssh 
     291                      ssh_sc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj)   ! initial salt content in ssh 
     292                   ENDDO 
    283293                ENDDO 
    284              ENDDO 
     294             ELSE 
     295                ssh_hc_loc_ini(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:)   ! initial heat content in ssh 
     296                ssh_sc_loc_ini(:,:) = tsn(:,:,1,jp_sal) * sshn(:,:)   ! initial salt content in ssh 
     297             END IF 
    285298             frc_wn_t = 0._wp                                       ! initial heat content misfit due to free surface 
    286299             frc_wn_s = 0._wp                                       ! initial salt content misfit due to free surface 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diahth.F90

    r4292 r5620  
    245245      CALL iom_put( "mldr10_3", zrho10_3     )   ! MLD delta rho(10m) = 0.03 
    246246      CALL iom_put( "pycndep" , zpycn        )   ! MLD delta rho equi. delta T(10m) = 0.2 
    247       CALL iom_put( "BLT"     , ztm2 - zpycn )   ! Barrier Layer Thickness 
    248247      CALL iom_put( "tinv"    , ztinv        )   ! max. temp. inv. (t10 ref)  
    249248      CALL iom_put( "depti"   , zdepinv      )   ! depth of max. temp. inv. (t10 ref)  
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90

    r5038 r5620  
    88   !!            3.2  ! 2010-03  (O. Marti, S. Flavoni) Add fields 
    99   !!            3.3  ! 2010-10  (G. Madec)  dynamical allocation 
     10   !!            3.6  ! 2014-12  (C. Ethe) use of IOM 
    1011   !!---------------------------------------------------------------------- 
    1112 
     
    1314   !!   dia_ptr      : Poleward Transport Diagnostics module 
    1415   !!   dia_ptr_init : Initialization, namelist read 
    15    !!   dia_ptr_wri  : Output of poleward fluxes 
    16    !!   ptr_vjk      : "zonal" sum computation of a "meridional" flux array 
    17    !!   ptr_tjk      : "zonal" mean computation of a tracer field 
    18    !!   ptr_vj       : "zonal" and vertical sum computation of a "meridional" flux array 
    19    !!                   (Generic interface to ptr_vj_3d, ptr_vj_2d) 
     16   !!   ptr_sjk      : "zonal" mean computation of a field - tracer or flux array 
     17   !!   ptr_sj       : "zonal" and vertical sum computation of a "meridional" flux array 
     18   !!                   (Generic interface to ptr_sj_3d, ptr_sj_2d) 
    2019   !!---------------------------------------------------------------------- 
    2120   USE oce              ! ocean dynamics and active tracers 
    2221   USE dom_oce          ! ocean space and time domain 
    2322   USE phycst           ! physical constants 
    24    USE ldftra_oce       ! ocean active tracers: lateral physics 
    25    USE dianam           ! 
     23   ! 
    2624   USE iom              ! IOM library 
    27    USE ioipsl           ! IO-IPSL library 
    2825   USE in_out_manager   ! I/O manager 
    2926   USE lib_mpp          ! MPP library 
    30    USE lbclnk           ! lateral boundary condition - processor exchanges 
    3127   USE timing           ! preformance summary 
    32    USE wrk_nemo         ! working arrays 
    3328 
    3429   IMPLICIT NONE 
    3530   PRIVATE 
    3631 
    37    INTERFACE ptr_vj 
    38       MODULE PROCEDURE ptr_vj_3d, ptr_vj_2d 
     32   INTERFACE ptr_sj 
     33      MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d 
    3934   END INTERFACE 
    4035 
    41    PUBLIC   dia_ptr_init   ! call in opa module 
     36   PUBLIC   ptr_sj         ! call by tra_ldf & tra_adv routines 
     37   PUBLIC   ptr_sjk        !  
     38   PUBLIC   dia_ptr_init   ! call in step module 
    4239   PUBLIC   dia_ptr        ! call in step module 
    43    PUBLIC   ptr_vj         ! call by tra_ldf & tra_adv routines 
    44    PUBLIC   ptr_vjk        ! call by tra_ldf & tra_adv routines 
    4540 
    4641   !                                  !!** namelist  namptr  ** 
    47    LOGICAL , PUBLIC ::   ln_diaptr     !: Poleward transport flag (T) or not (F) 
    48    LOGICAL , PUBLIC ::   ln_subbas     !: Atlantic/Pacific/Indian basins calculation 
    49    LOGICAL , PUBLIC ::   ln_diaznl     !: Add zonal means and meridional stream functions 
    50    LOGICAL , PUBLIC ::   ln_ptrcomp    !: Add decomposition : overturning (and gyre, soon ...) 
    51    INTEGER , PUBLIC ::   nn_fptr       !: frequency of ptr computation  [time step] 
    52    INTEGER , PUBLIC ::   nn_fwri       !: frequency of ptr outputs      [time step] 
    53  
    54    REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   htr_adv, htr_ldf, htr_ove   !: Heat TRansports (adv, diff, overturn.) 
    55    REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   str_adv, str_ldf, str_ove   !: Salt TRansports (adv, diff, overturn.) 
     42   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   htr_adv, htr_ldf   !: Heat TRansports (adv, diff, overturn.) 
     43   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   str_adv, str_ldf   !: Salt TRansports (adv, diff, overturn.) 
    5644    
    57    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   btmsk                  ! T-point basin interior masks 
    58    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   btm30                  ! mask out Southern Ocean (=0 south of 30°S) 
    59    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htr  , str             ! adv heat and salt transports (approx) 
    60    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tn_jk, sn_jk , v_msf   ! i-mean T and S, j-Stream-Function 
    61    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sjk  , r1_sjk          ! i-mean i-k-surface and its inverse         
    62    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htr_eiv, str_eiv       ! bolus adv heat ans salt transports ('key_diaeiv') 
    63    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   v_msf_eiv              ! bolus j-streamfuction              ('key_diaeiv') 
    64  
    65  
    66    INTEGER ::   niter       ! 
    67    INTEGER ::   nidom_ptr   ! 
    68    INTEGER ::   numptr      ! logical unit for Poleward TRansports 
    69    INTEGER ::   nptr        ! = 1 (ln_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (ln_subbas=T)  
     45 
     46   LOGICAL, PUBLIC ::   ln_diaptr   !  Poleward transport flag (T) or not (F) 
     47   LOGICAL, PUBLIC ::   ln_subbas   !  Atlantic/Pacific/Indian basins calculation 
     48   INTEGER         ::   nptr        ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T)  
    7049 
    7150   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup 
     
    7352   REAL(wp) ::   rc_ggram = 1.e-6_wp   ! conversion from g    to Pg 
    7453 
    75    REAL(wp), TARGET, DIMENSION(:),   ALLOCATABLE, SAVE :: p_fval1d 
    76    REAL(wp), TARGET, DIMENSION(:,:), ALLOCATABLE, SAVE :: p_fval2d 
    77  
    78    !! Integer, 1D workspace arrays. Not common enough to be implemented in  
    79    !! wrk_nemo module. 
    80    INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex  , ndex_atl     , ndex_pac     , ndex_ind     , ndex_ipc 
    81    INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) ::         ndex_atl_30  , ndex_pac_30  , ndex_ind_30  , ndex_ipc_30 
    82    INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 
     54   CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:)     :: clsubb 
     55   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk   ! T-point basin interior masks 
     56   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   :: btm30   ! mask out Southern Ocean (=0 south of 30°S) 
     57 
     58   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:)     :: p_fval1d 
     59   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:)   :: p_fval2d 
     60 
    8361 
    8462   !! * Substitutions 
     
    9270CONTAINS 
    9371 
    94    FUNCTION dia_ptr_alloc() 
    95       !!---------------------------------------------------------------------- 
    96       !!                    ***  ROUTINE dia_ptr_alloc  *** 
    97       !!---------------------------------------------------------------------- 
    98       INTEGER               ::   dia_ptr_alloc   ! return value 
    99       INTEGER, DIMENSION(6) ::   ierr 
    100       !!---------------------------------------------------------------------- 
    101       ierr(:) = 0 
    102       ! 
    103       ALLOCATE( btmsk(jpi,jpj,nptr) ,           & 
    104          &      htr_adv(jpj) , str_adv(jpj) ,   & 
    105          &      htr_ldf(jpj) , str_ldf(jpj) ,   & 
    106          &      htr_ove(jpj) , str_ove(jpj),    & 
    107          &      htr(jpj,nptr) , str(jpj,nptr) , & 
    108          &      tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , & 
    109          &      sjk  (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1)  ) 
    110          ! 
    111 #if defined key_diaeiv 
    112       ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 
    113          &      v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) ) 
    114 #endif 
    115       ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(3)) 
    116       ! 
    117       ALLOCATE(ndex(jpj*jpk),        ndex_atl(jpj*jpk), ndex_pac(jpj*jpk), & 
    118          &     ndex_ind(jpj*jpk),    ndex_ipc(jpj*jpk),                    & 
    119          &     ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(4)) 
    120  
    121       ALLOCATE(ndex_ind_30(jpj*jpk), ndex_ipc_30(jpj*jpk),                   & 
    122          &     ndex_h(jpj),          ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), & 
    123          &     ndex_h_ind_30(jpj),   ndex_h_ipc_30(jpj), Stat=ierr(5) ) 
    124          ! 
    125      ALLOCATE( btm30(jpi,jpj) , STAT=ierr(6)  ) 
    126          ! 
    127       dia_ptr_alloc = MAXVAL( ierr ) 
    128       IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc ) 
    129       ! 
    130    END FUNCTION dia_ptr_alloc 
    131  
    132  
    133    FUNCTION ptr_vj_3d( pva )   RESULT ( p_fval ) 
    134       !!---------------------------------------------------------------------- 
    135       !!                    ***  ROUTINE ptr_vj_3d  *** 
    136       !! 
    137       !! ** Purpose :   i-k sum computation of a j-flux array 
    138       !! 
    139       !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i). 
    140       !!              pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 
    141       !! 
    142       !! ** Action  : - p_fval: i-k-mean poleward flux of pva 
    143       !!---------------------------------------------------------------------- 
    144       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pva   ! mask flux array at V-point 
    145       !! 
    146       INTEGER                  ::   ji, jj, jk   ! dummy loop arguments 
    147       INTEGER                  ::   ijpj         ! ??? 
    148       REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value 
    149       !!-------------------------------------------------------------------- 
    150       ! 
    151       p_fval => p_fval1d 
    152  
    153       ijpj = jpj 
    154       p_fval(:) = 0._wp 
    155       DO jk = 1, jpkm1 
    156          DO jj = 2, jpjm1 
    157             DO ji = fs_2, fs_jpim1   ! Vector opt. 
    158                p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)  
    159             END DO 
    160          END DO 
    161       END DO 
    162 #if defined key_mpp_mpi 
    163       IF(lk_mpp)   CALL mpp_sum( p_fval, ijpj, ncomm_znl) 
    164 #endif 
    165       ! 
    166    END FUNCTION ptr_vj_3d 
    167  
    168  
    169    FUNCTION ptr_vj_2d( pva )   RESULT ( p_fval ) 
    170       !!---------------------------------------------------------------------- 
    171       !!                    ***  ROUTINE ptr_vj_2d  *** 
    172       !! 
    173       !! ** Purpose :   "zonal" and vertical sum computation of a i-flux array 
    174       !! 
    175       !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i). 
    176       !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 
    177       !! 
    178       !! ** Action  : - p_fval: i-k-mean poleward flux of pva 
    179       !!---------------------------------------------------------------------- 
    180       IMPLICIT none 
    181       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pva   ! mask flux array at V-point 
    182       !! 
    183       INTEGER                  ::   ji,jj       ! dummy loop arguments 
    184       INTEGER                  ::   ijpj        ! ??? 
    185       REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 
    186       !!-------------------------------------------------------------------- 
    187       !  
    188       p_fval => p_fval1d 
    189  
    190       ijpj = jpj 
    191       p_fval(:) = 0._wp 
    192       DO jj = 2, jpjm1 
    193          DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ? 
    194             p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) 
    195          END DO 
    196       END DO 
    197 #if defined key_mpp_mpi 
    198       CALL mpp_sum( p_fval, ijpj, ncomm_znl ) 
    199 #endif 
    200       !  
    201    END FUNCTION ptr_vj_2d 
    202  
    203  
    204    FUNCTION ptr_vjk( pva, pmsk )   RESULT ( p_fval ) 
    205       !!---------------------------------------------------------------------- 
    206       !!                    ***  ROUTINE ptr_vjk  *** 
    207       !! 
    208       !! ** Purpose :   i-sum computation of a j-velocity array 
    209       !! 
    210       !! ** Method  : - i-sum of pva using the interior 2D vmask (vmask_i). 
    211       !!              pva is supposed to be a masked flux (i.e. * vmask) 
    212       !! 
    213       !! ** Action  : - p_fval: i-mean poleward flux of pva 
    214       !!---------------------------------------------------------------------- 
    215       !! 
    216       IMPLICIT none 
    217       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pva    ! mask flux array at V-point 
    218       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)    , OPTIONAL ::   pmsk   ! Optional 2D basin mask 
    219       !! 
    220       INTEGER                           :: ji, jj, jk ! dummy loop arguments 
    221       REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value 
    222 #if defined key_mpp_mpi 
    223       INTEGER, DIMENSION(1) ::   ish 
    224       INTEGER, DIMENSION(2) ::   ish2 
    225       INTEGER               ::   ijpjjpk 
    226 #endif 
    227 #if defined key_mpp_mpi 
    228       REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point 
    229 #endif 
    230       !!-------------------------------------------------------------------- 
    231       ! 
    232 #if defined key_mpp_mpi 
    233       ijpjjpk = jpj*jpk 
    234       CALL wrk_alloc( jpj*jpk, zwork ) 
    235 #endif 
    236  
    237       p_fval => p_fval2d 
    238  
    239       p_fval(:,:) = 0._wp 
    240       ! 
    241       IF( PRESENT( pmsk ) ) THEN  
    242          DO jk = 1, jpkm1 
    243             DO jj = 2, jpjm1 
    244 !!gm here, use of tmask_i  ==> no need of loop over nldi, nlei.... 
    245                DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
    246                   p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * pmsk(ji,jj) 
     72   SUBROUTINE dia_ptr( pvtr ) 
     73      !!---------------------------------------------------------------------- 
     74      !!                  ***  ROUTINE dia_ptr  *** 
     75      !!---------------------------------------------------------------------- 
     76      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   pvtr   ! j-effective transport 
     77      ! 
     78      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     79      REAL(wp) ::   zv, zsfc               ! local scalar 
     80      REAL(wp), DIMENSION(jpi,jpj)     ::  z2d   ! 2D workspace 
     81      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  z3d   ! 3D workspace 
     82      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zmask   ! 3D workspace 
     83      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::  zts   ! 3D workspace 
     84      CHARACTER( len = 10 )  :: cl1 
     85      !!---------------------------------------------------------------------- 
     86      ! 
     87      IF( nn_timing == 1 )   CALL timing_start('dia_ptr') 
     88 
     89      ! 
     90      IF( PRESENT( pvtr ) ) THEN 
     91         IF( iom_use("zomsfglo") ) THEN    ! effective MSF 
     92            z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) )  ! zonal cumulative effective transport 
     93            DO jk = 2, jpkm1  
     94              z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk)   ! effective j-Stream-Function (MSF) 
     95            END DO 
     96            DO ji = 1, jpi 
     97               z3d(ji,:,:) = z3d(1,:,:) 
     98            ENDDO 
     99            cl1 = TRIM('zomsf'//clsubb(1) ) 
     100            CALL iom_put( cl1, z3d * rc_sv ) 
     101            DO jn = 2, nptr                                    ! by sub-basins 
     102               z3d(1,:,:) =  ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn)*btm30(:,:) )  
     103               DO jk = 2, jpkm1  
     104                  z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk)    ! effective j-Stream-Function (MSF) 
    247105               END DO 
    248             END DO 
    249          END DO 
    250       ELSE  
    251          DO jk = 1, jpkm1 
    252             DO jj = 2, jpjm1 
    253                DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
    254                   p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * tmask_i(ji,jj) 
    255                END DO 
    256             END DO 
    257          END DO 
    258       END IF 
    259       ! 
    260 #if defined key_mpp_mpi 
    261       ijpjjpk = jpj*jpk 
    262       ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    263       zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 
    264       CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 
    265       p_fval(:,:) = RESHAPE( zwork, ish2 ) 
    266 #endif 
    267       ! 
    268 #if defined key_mpp_mpi 
    269       CALL wrk_dealloc( jpj*jpk, zwork ) 
    270 #endif 
    271       ! 
    272    END FUNCTION ptr_vjk 
    273  
    274  
    275    FUNCTION ptr_tjk( pta, pmsk )   RESULT ( p_fval ) 
    276       !!---------------------------------------------------------------------- 
    277       !!                    ***  ROUTINE ptr_tjk  *** 
    278       !! 
    279       !! ** Purpose :   i-sum computation of e1t*e3t * a tracer field 
    280       !! 
    281       !! ** Method  : - i-sum of mj(pta) using tmask 
    282       !! 
    283       !! ** Action  : - p_fval: i-sum of e1t*e3t*pta 
    284       !!---------------------------------------------------------------------- 
    285       !! 
    286       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! tracer flux array at T-point 
    287       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)     ::   pmsk   ! Optional 2D basin mask 
    288       !! 
    289       INTEGER                           :: ji, jj, jk   ! dummy loop arguments 
    290       REAL(wp), POINTER, DIMENSION(:,:) :: p_fval       ! return function value 
    291 #if defined key_mpp_mpi 
    292       INTEGER, DIMENSION(1) ::   ish 
    293       INTEGER, DIMENSION(2) ::   ish2 
    294       INTEGER               ::   ijpjjpk 
    295 #endif 
    296 #if defined key_mpp_mpi 
    297       REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point 
    298 #endif 
    299       !!--------------------------------------------------------------------  
    300       ! 
    301 #if defined key_mpp_mpi 
    302       ijpjjpk = jpj*jpk 
    303       CALL wrk_alloc( jpj*jpk, zwork ) 
    304 #endif 
    305  
    306       p_fval => p_fval2d 
    307  
    308       p_fval(:,:) = 0._wp 
    309       DO jk = 1, jpkm1 
    310          DO jj = 2, jpjm1 
    311             DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
    312                p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj) 
    313             END DO 
    314          END DO 
    315       END DO 
    316 #if defined key_mpp_mpi 
    317       ijpjjpk = jpj*jpk 
    318       ish(1) = jpj*jpk   ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    319       zwork(1:ijpjjpk)= RESHAPE( p_fval, ish ) 
    320       CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 
    321       p_fval(:,:)= RESHAPE( zwork, ish2 ) 
    322 #endif 
    323       ! 
    324 #if defined key_mpp_mpi 
    325       CALL wrk_dealloc( jpj*jpk, zwork ) 
    326 #endif 
    327       !     
    328    END FUNCTION ptr_tjk 
    329  
    330  
    331    SUBROUTINE dia_ptr( kt ) 
    332       !!---------------------------------------------------------------------- 
    333       !!                  ***  ROUTINE dia_ptr  *** 
    334       !!---------------------------------------------------------------------- 
    335       USE oce,     vt  =>   ua   ! use ua as workspace 
    336       USE oce,     vs  =>   va   ! use va as workspace 
    337       IMPLICIT none 
    338       !! 
    339       INTEGER, INTENT(in) ::   kt   ! ocean time step index 
    340       ! 
    341       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    342       REAL(wp) ::   zv               ! local scalar 
    343       !!---------------------------------------------------------------------- 
    344       ! 
    345       IF( nn_timing == 1 )   CALL timing_start('dia_ptr') 
    346       ! 
    347       IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 )   THEN 
    348          ! 
    349          IF( MOD( kt, nn_fptr ) == 0 ) THEN  
    350             ! 
    351             IF( ln_diaznl ) THEN               ! i-mean temperature and salinity 
    352                DO jn = 1, nptr 
    353                   tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
    354                   sn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
    355                END DO 
    356             ENDIF 
    357             ! 
    358             !                          ! horizontal integral and vertical dz  
    359             !                                ! eulerian velocity 
    360             v_msf(:,:,1) = ptr_vjk( vn(:,:,:) )  
    361             DO jn = 2, nptr 
    362                v_msf(:,:,jn) = ptr_vjk( vn(:,:,:), btmsk(:,:,jn)*btm30(:,:) )  
    363             END DO 
    364 #if defined key_diaeiv 
    365             DO jn = 1, nptr                  ! bolus velocity 
    366                v_msf_eiv(:,:,jn) = ptr_vjk( v_eiv(:,:,:), btmsk(:,:,jn) )   ! here no btm30 for MSFeiv 
    367             END DO 
    368             !                                ! add bolus stream-function to the eulerian one 
    369             v_msf(:,:,:) = v_msf(:,:,:) + v_msf_eiv(:,:,:) 
    370 #endif 
    371             ! 
    372             !                          ! Transports 
    373             !                                ! local heat & salt transports at T-points  ( tsn*mj[vn+v_eiv] ) 
    374             vt(:,:,jpk) = 0._wp   ;   vs(:,:,jpk) = 0._wp 
    375             DO jk= 1, jpkm1 
    376                DO jj = 2, jpj 
     106               DO ji = 1, jpi 
     107                  z3d(ji,:,:) = z3d(1,:,:) 
     108               ENDDO 
     109               cl1 = TRIM('zomsf'//clsubb(jn) ) 
     110               CALL iom_put( cl1, z3d * rc_sv ) 
     111            END DO 
     112         ENDIF 
     113         ! 
     114      ELSE 
     115         ! 
     116         IF( iom_use("zotemglo") ) THEN    ! i-mean i-k-surface  
     117            DO jk = 1, jpkm1 
     118               DO jj = 1, jpj 
    377119                  DO ji = 1, jpi 
    378 #if defined key_diaeiv  
    379                      zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) + v_eiv(ji,jj,jk) + v_eiv(ji,jj-1,jk) ) * 0.5_wp 
    380 #else 
    381                      zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp 
    382 #endif  
    383                      vt(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_tem) 
    384                      vs(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_sal) 
    385                   END DO 
    386                END DO 
    387             END DO 
    388 !!gm useless as overlap areas are not used in ptr_vjk 
    389             CALL lbc_lnk( vs, 'V', -1. )   ;   CALL lbc_lnk( vt, 'V', -1. ) 
    390 !!gm 
    391             !                                ! heat & salt advective transports (approximation) 
    392             htr(:,1) = SUM( ptr_vjk( vt(:,:,:) ) , 2 ) * rc_pwatt   ! SUM over jk + conversion 
    393             str(:,1) = SUM( ptr_vjk( vs(:,:,:) ) , 2 ) * rc_ggram 
    394             DO jn = 2, nptr  
    395                htr(:,jn) = SUM( ptr_vjk( vt(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_pwatt   ! mask Southern Ocean 
    396                str(:,jn) = SUM( ptr_vjk( vs(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_ggram   ! mask Southern Ocean 
    397             END DO 
    398  
    399             IF( ln_ptrcomp ) THEN            ! overturning transport 
    400                htr_ove(:) = SUM( v_msf(:,:,1) * tn_jk(:,:,1), 2 ) * rc_pwatt   ! SUM over jk + conversion 
    401                str_ove(:) = SUM( v_msf(:,:,1) * sn_jk(:,:,1), 2 ) * rc_ggram 
    402             END IF 
    403             !                                ! Advective and diffusive transport 
    404             htr_adv(:) = htr_adv(:) * rc_pwatt        ! these are computed in tra_adv... and tra_ldf... routines  
    405             htr_ldf(:) = htr_ldf(:) * rc_pwatt        ! here just the conversion in PW and Gg 
    406             str_adv(:) = str_adv(:) * rc_ggram 
    407             str_ldf(:) = str_ldf(:) * rc_ggram 
    408  
    409 #if defined key_diaeiv 
    410             DO jn = 1, nptr                  ! Bolus component 
    411                htr_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * tn_jk(:,:,jn), 2 ) * rc_pwatt   ! SUM over jk 
    412                str_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * sn_jk(:,:,jn), 2 ) * rc_ggram   ! SUM over jk 
    413             END DO 
    414 #endif 
    415             !                                ! "Meridional" Stream-Function 
     120                     zsfc = e1t(ji,jj) * fse3t(ji,jj,jk) 
     121                     zmask(ji,jj,jk)      = tmask(ji,jj,jk)      * zsfc 
     122                     zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc 
     123                     zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc 
     124                  ENDDO 
     125               ENDDO 
     126            ENDDO 
    416127            DO jn = 1, nptr 
    417                DO jk = 2, jpk  
    418                   v_msf    (:,jk,jn) = v_msf    (:,jk-1,jn) + v_msf    (:,jk,jn)       ! Eulerian j-Stream-Function 
    419 #if defined key_diaeiv 
    420                   v_msf_eiv(:,jk,jn) = v_msf_eiv(:,jk-1,jn) + v_msf_eiv(:,jk,jn)       ! Bolus    j-Stream-Function 
    421  
    422 #endif 
    423                END DO 
    424             END DO 
    425             v_msf    (:,:,:) = v_msf    (:,:,:) * rc_sv       ! converte in Sverdrups 
    426 #if defined key_diaeiv 
    427             v_msf_eiv(:,:,:) = v_msf_eiv(:,:,:) * rc_sv 
    428 #endif 
    429          ENDIF 
    430          ! 
    431          CALL dia_ptr_wri( kt )                        ! outputs 
     128               zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 
     129               cl1 = TRIM('zosrf'//clsubb(jn) ) 
     130               CALL iom_put( cl1, zmask ) 
     131               ! 
     132               z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 
     133                  &            / MAX( zmask(1,:,:), 10.e-15 ) 
     134               DO ji = 1, jpi 
     135                  z3d(ji,:,:) = z3d(1,:,:) 
     136               ENDDO 
     137               cl1 = TRIM('zotem'//clsubb(jn) ) 
     138               CALL iom_put( cl1, z3d ) 
     139               ! 
     140               z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 
     141                  &            / MAX( zmask(1,:,:), 10.e-15 ) 
     142               DO ji = 1, jpi 
     143                  z3d(ji,:,:) = z3d(1,:,:) 
     144               ENDDO 
     145               cl1 = TRIM('zosal'//clsubb(jn) ) 
     146               CALL iom_put( cl1, z3d ) 
     147            END DO 
     148         ENDIF 
     149         ! 
     150         !                                ! Advective and diffusive heat and salt transport 
     151         IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN    
     152            z2d(1,:) = htr_adv(:) * rc_pwatt        !  (conversion in PW) 
     153            DO ji = 1, jpi 
     154               z2d(ji,:) = z2d(1,:) 
     155            ENDDO 
     156            cl1 = 'sophtadv'                  
     157            CALL iom_put( TRIM(cl1), z2d ) 
     158            z2d(1,:) = str_adv(:) * rc_ggram        ! (conversion in Gg) 
     159            DO ji = 1, jpi 
     160               z2d(ji,:) = z2d(1,:) 
     161            ENDDO 
     162            cl1 = 'sopstadv' 
     163            CALL iom_put( TRIM(cl1), z2d ) 
     164         ENDIF 
     165         ! 
     166         IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN    
     167            z2d(1,:) = htr_ldf(:) * rc_pwatt        !  (conversion in PW)  
     168            DO ji = 1, jpi 
     169               z2d(ji,:) = z2d(1,:) 
     170            ENDDO 
     171            cl1 = 'sophtldf' 
     172            CALL iom_put( TRIM(cl1), z2d ) 
     173            z2d(1,:) = str_ldf(:) * rc_ggram        !  (conversion in Gg) 
     174            DO ji = 1, jpi 
     175               z2d(ji,:) = z2d(1,:) 
     176            ENDDO 
     177            cl1 = 'sopstldf' 
     178            CALL iom_put( TRIM(cl1), z2d ) 
     179         ENDIF 
    432180         ! 
    433181      ENDIF 
    434       ! 
    435 #if defined key_mpp_mpi 
    436       IF( kt == nitend .AND. l_znl_root )   CALL histclo( numptr )      ! Close the file 
    437 #else 
    438       IF( kt == nitend )                    CALL histclo( numptr )      ! Close the file 
    439 #endif 
    440182      ! 
    441183      IF( nn_timing == 1 )   CALL timing_stop('dia_ptr') 
     
    450192      !! ** Purpose :   Initialization, namelist read 
    451193      !!---------------------------------------------------------------------- 
    452       INTEGER ::   jn           ! dummy loop indices  
    453       INTEGER ::   inum, ierr   ! local integers 
    454       INTEGER ::   ios          ! Local integer output status for namelist read 
    455 #if defined key_mpp_mpi 
    456       INTEGER, DIMENSION(1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid 
    457 #endif 
    458       !! 
    459       NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri 
     194      INTEGER ::  jn           ! local integers 
     195      INTEGER ::  inum, ierr   ! local integers 
     196      INTEGER ::  ios          ! Local integer output status for namelist read 
     197      !! 
     198      NAMELIST/namptr/ ln_diaptr, ln_subbas 
    460199      !!---------------------------------------------------------------------- 
    461200 
     
    475214         WRITE(numout,*) '   Namelist namptr : set ptr parameters' 
    476215         WRITE(numout,*) '      Poleward heat & salt transport (T) or not (F)      ln_diaptr  = ', ln_diaptr 
    477          WRITE(numout,*) '      Overturning heat & salt transport                  ln_ptrcomp = ', ln_ptrcomp 
    478          WRITE(numout,*) '      T & S zonal mean and meridional stream function    ln_diaznl  = ', ln_diaznl  
    479216         WRITE(numout,*) '      Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins      ln_subbas  = ', ln_subbas 
    480          WRITE(numout,*) '      Frequency of computation                           nn_fptr    = ', nn_fptr 
    481          WRITE(numout,*) '      Frequency of outputs                               nn_fwri    = ', nn_fwri 
    482217      ENDIF 
    483        
    484       IF( ln_diaptr) THEN   
    485       
    486          IF( nn_timing == 1 )   CALL timing_start('dia_ptr_init') 
    487        
    488          IF( ln_subbas ) THEN   ;   nptr = 5       ! Global, Atlantic, Pacific, Indian, Indo-Pacific 
    489          ELSE                   ;   nptr = 1       ! Global only 
     218 
     219      IF( ln_diaptr ) THEN   
     220         ! 
     221         IF( ln_subbas ) THEN  
     222            nptr = 5            ! Global, Atlantic, Pacific, Indian, Indo-Pacific 
     223            ALLOCATE( clsubb(nptr) ) 
     224            clsubb(1) = 'glo' ;  clsubb(2) = 'atl'  ;  clsubb(3) = 'pac'  ;  clsubb(4) = 'ind'  ;  clsubb(5) = 'ipc' 
     225         ELSE                
     226            nptr = 1       ! Global only 
     227            ALLOCATE( clsubb(nptr) ) 
     228            clsubb(1) = 'glo'  
    490229         ENDIF 
    491230 
     
    493232         IF( dia_ptr_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 
    494233 
    495          rc_pwatt = rc_pwatt * rau0 * rcp          ! conversion from K.s-1 to PetaWatt 
     234         rc_pwatt = rc_pwatt * rau0_rcp          ! conversion from K.s-1 to PetaWatt 
    496235 
    497236         IF( lk_mpp )   CALL mpp_ini_znl( numout )     ! Define MPI communicator for zonal sum 
    498237 
    499238         IF( ln_subbas ) THEN                ! load sub-basin mask 
    500             CALL iom_open( 'subbasins', inum ) 
     239            CALL iom_open( 'subbasins', inum,  ldstop = .FALSE. ) 
    501240            CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) )   ! Atlantic basin 
    502241            CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) )   ! Pacific  basin 
     
    508247            END WHERE 
    509248         ENDIF 
     249    
    510250         btmsk(:,:,1) = tmask_i(:,:)                                   ! global ocean 
    511251       
     
    513253            btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:)               ! interior domain only 
    514254         END DO 
    515        
    516          IF( lk_vvl )   CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' ) 
    517  
    518          !                                   ! i-sum of e1v*e3v surface and its inverse 
    519          DO jn = 1, nptr 
    520             sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) ) 
    521             r1_sjk(:,:,jn) = 0._wp 
    522             WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 
    523          END DO 
    524  
    525       ! Initialise arrays to zero because diatpr is called before they are first calculated 
    526       ! Note that this means diagnostics will not be exactly correct when model run is restarted. 
    527       htr_adv(:) = 0._wp ; str_adv(:) =  0._wp ;  htr_ldf(:) = 0._wp ; str_ldf(:) =  0._wp 
    528  
    529 #if defined key_mpp_mpi  
    530          iglo (1) = jpjglo                   ! MPP case using MPI  ('key_mpp_mpi') 
    531          iloc (1) = nlcj 
    532          iabsf(1) = njmppt(narea) 
    533          iabsl(:) = iabsf(:) + iloc(:) - 1 
    534          ihals(1) = nldj - 1 
    535          ihale(1) = nlcj - nlej 
    536          idid (1) = 2 
    537          CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr ) 
    538 #else 
    539          nidom_ptr = FLIO_DOM_NONE 
    540 #endif 
    541       IF( nn_timing == 1 )   CALL timing_stop('dia_ptr_init') 
    542       ! 
     255 
     256         ! Initialise arrays to zero because diatpr is called before they are first calculated 
     257         ! Note that this means diagnostics will not be exactly correct when model run is restarted. 
     258         htr_adv(:) = 0._wp  ;  str_adv(:) =  0._wp   
     259         htr_ldf(:) = 0._wp  ;  str_ldf(:) =  0._wp  
     260         ! 
    543261      ENDIF  
    544262      !  
     
    546264 
    547265 
    548    SUBROUTINE dia_ptr_wri( kt ) 
    549       !!--------------------------------------------------------------------- 
    550       !!                ***  ROUTINE dia_ptr_wri  *** 
    551       !! 
    552       !! ** Purpose :   output of poleward fluxes 
    553       !! 
    554       !! ** Method  :   NetCDF file 
    555       !!---------------------------------------------------------------------- 
    556       !! 
    557       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    558       !! 
    559       INTEGER, SAVE ::   nhoridz, ndepidzt, ndepidzw 
    560       INTEGER, SAVE ::   ndim  , ndim_atl     , ndim_pac     , ndim_ind     , ndim_ipc 
    561       INTEGER, SAVE ::           ndim_atl_30  , ndim_pac_30  , ndim_ind_30  , ndim_ipc_30 
    562       INTEGER, SAVE ::   ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 
    563       !! 
    564       CHARACTER (len=40) ::   clhstnam, clop, clop_once, cl_comment   ! temporary names 
    565       INTEGER            ::   iline, it, itmod, ji, jj, jk            ! 
    566 #if defined key_iomput 
    567       INTEGER            ::   inum                                    ! temporary logical unit 
     266   FUNCTION dia_ptr_alloc() 
     267      !!---------------------------------------------------------------------- 
     268      !!                    ***  ROUTINE dia_ptr_alloc  *** 
     269      !!---------------------------------------------------------------------- 
     270      INTEGER               ::   dia_ptr_alloc   ! return value 
     271      INTEGER, DIMENSION(3) ::   ierr 
     272      !!---------------------------------------------------------------------- 
     273      ierr(:) = 0 
     274      ! 
     275      ALLOCATE( btmsk(jpi,jpj,nptr) ,           & 
     276         &      htr_adv(jpj) , str_adv(jpj) ,   & 
     277         &      htr_ldf(jpj) , str_ldf(jpj) , STAT=ierr(1)  ) 
     278         ! 
     279      ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 
     280      ! 
     281      ALLOCATE( btm30(jpi,jpj), STAT=ierr(3)  ) 
     282 
     283         ! 
     284      dia_ptr_alloc = MAXVAL( ierr ) 
     285      IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc ) 
     286      ! 
     287   END FUNCTION dia_ptr_alloc 
     288 
     289 
     290   FUNCTION ptr_sj_3d( pva, pmsk )   RESULT ( p_fval ) 
     291      !!---------------------------------------------------------------------- 
     292      !!                    ***  ROUTINE ptr_sj_3d  *** 
     293      !! 
     294      !! ** Purpose :   i-k sum computation of a j-flux array 
     295      !! 
     296      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i). 
     297      !!              pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 
     298      !! 
     299      !! ** Action  : - p_fval: i-k-mean poleward flux of pva 
     300      !!---------------------------------------------------------------------- 
     301      REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk)       ::   pva   ! mask flux array at V-point 
     302      REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL ::   pmsk   ! Optional 2D basin mask 
     303      ! 
     304      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments 
     305      INTEGER                  ::   ijpj         ! ??? 
     306      REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value 
     307      !!-------------------------------------------------------------------- 
     308      ! 
     309      p_fval => p_fval1d 
     310 
     311      ijpj = jpj 
     312      p_fval(:) = 0._wp 
     313      IF( PRESENT( pmsk ) ) THEN  
     314         DO jk = 1, jpkm1 
     315            DO jj = 2, jpjm1 
     316               DO ji = fs_2, fs_jpim1   ! Vector opt. 
     317                  p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj) 
     318               END DO 
     319            END DO 
     320         END DO 
     321      ELSE 
     322         DO jk = 1, jpkm1 
     323            DO jj = 2, jpjm1 
     324               DO ji = fs_2, fs_jpim1   ! Vector opt. 
     325                  p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)  
     326               END DO 
     327            END DO 
     328         END DO 
     329      ENDIF 
     330#if defined key_mpp_mpi 
     331      IF(lk_mpp)   CALL mpp_sum( p_fval, ijpj, ncomm_znl) 
    568332#endif 
    569       REAL(wp)           ::   zsto, zout, zdt, zjulian                ! temporary scalars 
    570       !! 
    571       REAL(wp), POINTER, DIMENSION(:)   ::   zphi, zfoo    ! 1D workspace 
    572       REAL(wp), POINTER, DIMENSION(:,:) ::   z_1           ! 2D workspace 
    573       !!--------------------------------------------------------------------  
    574       ! 
    575       CALL wrk_alloc( jpj       , zphi , zfoo ) 
    576       CALL wrk_alloc( jpj , jpk , z_1  ) 
    577  
    578       ! define time axis 
    579       it    = kt / nn_fptr 
    580       itmod = kt - nit000 + 1 
    581        
    582       ! Initialization 
    583       ! -------------- 
    584       IF( kt == nit000 ) THEN 
    585          niter = ( nit000 - 1 ) / nn_fptr 
    586          zdt = rdt 
    587          IF( nacc == 1 )   zdt = rdtmin 
    588          ! 
    589          IF(lwp) THEN 
    590             WRITE(numout,*) 
    591             WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter 
    592             WRITE(numout,*) '~~~~~~~~~~~~' 
    593          ENDIF 
    594  
    595          ! Reference latitude (used in plots) 
    596          ! ------------------ 
    597          !                                           ! ======================= 
    598          IF( cp_cfg == "orca" ) THEN                 !   ORCA configurations 
    599             !                                        ! ======================= 
    600             IF( jp_cfg == 05  )   iline = 192   ! i-line that passes near the North Pole 
    601             IF( jp_cfg == 025 )   iline = 384   ! i-line that passes near the North Pole 
    602             IF( jp_cfg == 1   )   iline =  96   ! i-line that passes near the North Pole 
    603             IF( jp_cfg == 2   )   iline =  48   ! i-line that passes near the North Pole 
    604             IF( jp_cfg == 4   )   iline =  24   ! i-line that passes near the North Pole 
    605             zphi(1:jpj) = 0._wp 
    606             DO ji = mi0(iline), mi1(iline)  
    607                zphi(1:jpj) = gphiv(ji,:)         ! if iline is in the local domain 
    608                ! Correct highest latitude for some configurations - will work if domain is parallelized in J ? 
    609                IF( jp_cfg == 05 ) THEN 
    610                   DO jj = mj0(jpjdta), mj1(jpjdta)  
    611                      zphi( jj ) = zphi(mj0(jpjdta-1)) + ( zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)) ) * 0.5_wp 
    612                      zphi( jj ) = MIN( zphi(jj), 90._wp ) 
    613                   END DO 
    614                END IF 
    615                IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN 
    616                   DO jj = mj0(jpjdta-1), mj1(jpjdta-1)  
    617                      zphi( jj ) = 88.5_wp 
    618                   END DO 
    619                   DO jj = mj0(jpjdta  ), mj1(jpjdta  )  
    620                      zphi( jj ) = 89.5_wp 
    621                   END DO 
    622                END IF 
    623             END DO 
    624             ! provide the correct zphi to all local domains 
     333      ! 
     334   END FUNCTION ptr_sj_3d 
     335 
     336 
     337   FUNCTION ptr_sj_2d( pva, pmsk )   RESULT ( p_fval ) 
     338      !!---------------------------------------------------------------------- 
     339      !!                    ***  ROUTINE ptr_sj_2d  *** 
     340      !! 
     341      !! ** Purpose :   "zonal" and vertical sum computation of a i-flux array 
     342      !! 
     343      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i). 
     344      !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 
     345      !! 
     346      !! ** Action  : - p_fval: i-k-mean poleward flux of pva 
     347      !!---------------------------------------------------------------------- 
     348      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)           ::   pva   ! mask flux array at V-point 
     349      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL ::   pmsk   ! Optional 2D basin mask 
     350      ! 
     351      INTEGER                  ::   ji,jj       ! dummy loop arguments 
     352      INTEGER                  ::   ijpj        ! ??? 
     353      REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 
     354      !!-------------------------------------------------------------------- 
     355      !  
     356      p_fval => p_fval1d 
     357 
     358      ijpj = jpj 
     359      p_fval(:) = 0._wp 
     360      IF( PRESENT( pmsk ) ) THEN  
     361         DO jj = 2, jpjm1 
     362            DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ? 
     363               p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj) 
     364            END DO 
     365         END DO 
     366      ELSE 
     367         DO jj = 2, jpjm1 
     368            DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ? 
     369               p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) 
     370            END DO 
     371         END DO 
     372      ENDIF 
    625373#if defined key_mpp_mpi 
    626             CALL mpp_sum( zphi, jpj, ncomm_znl )         
     374      CALL mpp_sum( p_fval, ijpj, ncomm_znl ) 
    627375#endif 
    628             !                                        ! ======================= 
    629          ELSE                                        !   OTHER configurations  
    630             !                                        ! ======================= 
    631             zphi(1:jpj) = gphiv(1,:)             ! assume lat/lon coordinate, select the first i-line 
    632             ! 
    633          ENDIF 
    634          ! 
    635          ! Work only on westmost processor (will not work if mppini2 is used) 
     376      !  
     377   END FUNCTION ptr_sj_2d 
     378 
     379 
     380   FUNCTION ptr_sjk( pta, pmsk )   RESULT ( p_fval ) 
     381      !!---------------------------------------------------------------------- 
     382      !!                    ***  ROUTINE ptr_sjk  *** 
     383      !! 
     384      !! ** Purpose :   i-sum computation of an array 
     385      !! 
     386      !! ** Method  : - i-sum of pva using the interior 2D vmask (vmask_i). 
     387      !! 
     388      !! ** Action  : - p_fval: i-mean poleward flux of pva 
     389      !!---------------------------------------------------------------------- 
     390      !! 
     391      IMPLICIT none 
     392      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pta    ! mask flux array at V-point 
     393      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)    , OPTIONAL ::   pmsk   ! Optional 2D basin mask 
     394      !! 
     395      INTEGER                           :: ji, jj, jk ! dummy loop arguments 
     396      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value 
    636397#if defined key_mpp_mpi 
    637          IF( l_znl_root ) THEN  
     398      INTEGER, DIMENSION(1) ::   ish 
     399      INTEGER, DIMENSION(2) ::   ish2 
     400      INTEGER               ::   ijpjjpk 
     401      REAL(wp), DIMENSION(jpj*jpk) ::   zwork    ! mask flux array at V-point 
    638402#endif 
    639             ! 
    640             ! OPEN netcdf file  
    641             ! ---------------- 
    642             ! Define frequency of output and means 
    643             zsto = nn_fptr * zdt 
    644             IF( ln_mskland )   THEN    ! put 1.e+20 on land (very expensive!!) 
    645                clop      = "ave(only(x))" 
    646                clop_once = "once(only(x))" 
    647             ELSE                       ! no use of the mask value (require less cpu time) 
    648                clop      = "ave(x)"        
    649                clop_once = "once" 
    650             ENDIF 
    651  
    652             zout = nn_fwri * zdt 
    653             zfoo(1:jpj) = 0._wp 
    654  
    655             CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )  ! Compute julian date from starting date of the run 
    656             zjulian = zjulian - adatrj                         ! set calendar origin to the beginning of the experiment 
    657  
    658 #if defined key_iomput 
    659             ! Requested by IPSL people, use by their postpro... 
    660             IF(lwp) THEN 
    661                CALL dia_nam( clhstnam, nn_fwri,' ' ) 
    662                CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    663                WRITE(inum,*) clhstnam 
    664                CLOSE(inum) 
    665             ENDIF 
     403      !!-------------------------------------------------------------------- 
     404      ! 
     405      p_fval => p_fval2d 
     406 
     407      p_fval(:,:) = 0._wp 
     408      ! 
     409      IF( PRESENT( pmsk ) ) THEN  
     410         DO jk = 1, jpkm1 
     411            DO jj = 2, jpjm1 
     412!!gm here, use of tmask_i  ==> no need of loop over nldi, nlei.... 
     413               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
     414                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) 
     415               END DO 
     416            END DO 
     417         END DO 
     418      ELSE  
     419         DO jk = 1, jpkm1 
     420            DO jj = 2, jpjm1 
     421               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
     422                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj) 
     423               END DO 
     424            END DO 
     425         END DO 
     426      END IF 
     427      ! 
     428#if defined key_mpp_mpi 
     429      ijpjjpk = jpj*jpk 
     430      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk 
     431      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 
     432      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 
     433      p_fval(:,:) = RESHAPE( zwork, ish2 ) 
    666434#endif 
    667  
    668             CALL dia_nam( clhstnam, nn_fwri, 'diaptr' ) 
    669             IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam 
    670  
    671             ! Horizontal grid : zphi() 
    672             CALL histbeg(clhstnam, 1, zfoo, jpj, zphi,   & 
    673                1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr) 
    674             ! Vertical grids : gdept_1d, gdepw_1d 
    675             CALL histvert( numptr, "deptht", "Vertical T levels",   & 
    676                &                   "m", jpk, gdept_1d, ndepidzt, "down" ) 
    677             CALL histvert( numptr, "depthw", "Vertical W levels",   & 
    678                &                   "m", jpk, gdepw_1d, ndepidzw, "down" ) 
    679             ! 
    680             CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex  , ndim  )      ! Lat-Depth 
    681             CALL wheneq ( jpj    , MIN(sjk(:,1,1), 1._wp), 1, 1., ndex_h, ndim_h )     ! Lat 
    682  
    683             IF( ln_subbas ) THEN 
    684                z_1(:,1) = 1._wp 
    685                WHERE ( gphit(jpi/2,:) < -30._wp )   z_1(:,1) = 0._wp 
    686                DO jk = 2, jpk 
    687                   z_1(:,jk) = z_1(:,1) 
    688                END DO 
    689                !                       ! Atlantic (jn=2) 
    690                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)         , 1._wp), 1, 1., ndex_atl     , ndim_atl      ) ! Lat-Depth 
    691                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)*z_1(:,:), 1._wp), 1, 1., ndex_atl_30  , ndim_atl_30   ) ! Lat-Depth 
    692                CALL wheneq ( jpj    , MIN(sjk(:,1,2)*z_1(:,1), 1._wp), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat 
    693                !                       ! Pacific (jn=3) 
    694                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)         , 1._wp), 1, 1., ndex_pac     , ndim_pac      ) ! Lat-Depth 
    695                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)*z_1(:,:), 1._wp), 1, 1., ndex_pac_30  , ndim_pac_30   ) ! Lat-Depth 
    696                CALL wheneq ( jpj    , MIN(sjk(:,1,3)*z_1(:,1), 1._wp), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat 
    697                !                       ! Indian (jn=4) 
    698                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)         , 1._wp), 1, 1., ndex_ind     , ndim_ind      ) ! Lat-Depth 
    699                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)*z_1(:,:), 1._wp), 1, 1., ndex_ind_30  , ndim_ind_30   ) ! Lat-Depth 
    700                CALL wheneq ( jpj    , MIN(sjk(:,1,4)*z_1(:,1), 1._wp), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat 
    701                !                       ! Indo-Pacific (jn=5) 
    702                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)         , 1._wp), 1, 1., ndex_ipc     , ndim_ipc      ) ! Lat-Depth 
    703                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)*z_1(:,:), 1._wp), 1, 1., ndex_ipc_30  , ndim_ipc_30   ) ! Lat-Depth 
    704                CALL wheneq ( jpj    , MIN(sjk(:,1,5)*z_1(:,1), 1._wp), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat 
    705             ENDIF 
    706             !  
    707 #if defined key_diaeiv 
    708             cl_comment = ' (Bolus part included)' 
    709 #else 
    710             cl_comment = '                      ' 
    711 #endif 
    712             IF( ln_diaznl ) THEN             !  Zonal mean T and S 
    713                CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" ,   & 
    714                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    715                CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU"  ,   & 
    716                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    717  
    718                CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2"   ,   & 
    719                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    720                ! 
    721                IF (ln_subbas) THEN  
    722                   CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" ,   & 
    723                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    724                   CALL histdef( numptr, "zosalatl", "Zonal Mean Salinity: Atlantic","PSU"  ,   & 
    725                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    726                   CALL histdef( numptr, "zosrfatl", "Zonal Mean Surface: Atlantic","m^2"   ,   & 
    727                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    728  
    729                   CALL histdef( numptr, "zotempac", "Zonal Mean Temperature: Pacific","C"  ,   & 
    730                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    731                   CALL histdef( numptr, "zosalpac", "Zonal Mean Salinity: Pacific","PSU"   ,   & 
    732                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    733                   CALL histdef( numptr, "zosrfpac", "Zonal Mean Surface: Pacific","m^2"    ,   & 
    734                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    735  
    736                   CALL histdef( numptr, "zotemind", "Zonal Mean Temperature: Indian","C"   ,   & 
    737                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    738                   CALL histdef( numptr, "zosalind", "Zonal Mean Salinity: Indian","PSU"    ,   & 
    739                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    740                   CALL histdef( numptr, "zosrfind", "Zonal Mean Surface: Indian","m^2"     ,   & 
    741                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    742  
    743                   CALL histdef( numptr, "zotemipc", "Zonal Mean Temperature: Pacific+Indian","C" ,   & 
    744                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    745                   CALL histdef( numptr, "zosalipc", "Zonal Mean Salinity: Pacific+Indian","PSU"  ,   & 
    746                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    747                   CALL histdef( numptr, "zosrfipc", "Zonal Mean Surface: Pacific+Indian","m^2"   ,   & 
    748                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    749                ENDIF 
    750             ENDIF 
    751             ! 
    752             !  Meridional Stream-Function (Eulerian and Bolus) 
    753             CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" ,   & 
    754                1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    755             IF( ln_subbas .AND. ln_diaznl ) THEN 
    756                CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic"//TRIM(cl_comment),"Sv" ,   & 
    757                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    758                CALL histdef( numptr, "zomsfpac", "Meridional Stream-Function: Pacific"//TRIM(cl_comment),"Sv"  ,   & 
    759                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    760                CALL histdef( numptr, "zomsfind", "Meridional Stream-Function: Indian"//TRIM(cl_comment),"Sv"   ,   & 
    761                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    762                CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific"//TRIM(cl_comment),"Sv" ,& 
    763                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    764             ENDIF 
    765             ! 
    766             !  Heat transport  
    767             CALL histdef( numptr, "sophtadv", "Advective Heat Transport"      ,   & 
    768                "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    769             CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport"      ,   & 
    770                "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    771             IF ( ln_ptrcomp ) THEN  
    772                CALL histdef( numptr, "sophtove", "Overturning Heat Transport"    ,   & 
    773                   "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    774             END IF 
    775             IF( ln_subbas ) THEN 
    776                CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic"//TRIM(cl_comment),  & 
    777                   "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    778                CALL histdef( numptr, "sohtpac", "Heat Transport Pacific"//TRIM(cl_comment) ,  & 
    779                   "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    780                CALL histdef( numptr, "sohtind", "Heat Transport Indian"//TRIM(cl_comment)  ,  & 
    781                   "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    782                CALL histdef( numptr, "sohtipc", "Heat Transport Pacific+Indian"//TRIM(cl_comment), & 
    783                   "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    784             ENDIF 
    785             ! 
    786             !  Salt transport  
    787             CALL histdef( numptr, "sopstadv", "Advective Salt Transport"      ,   & 
    788                "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    789             CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport"      ,   & 
    790                "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    791             IF ( ln_ptrcomp ) THEN  
    792                CALL histdef( numptr, "sopstove", "Overturning Salt Transport"    ,   & 
    793                   "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    794             END IF 
    795 #if defined key_diaeiv 
    796             ! Eddy induced velocity 
    797             CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global",   & 
    798                "Sv"      , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    799             CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport",   & 
    800                "PW"      , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    801             CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport",   & 
    802                "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    803 #endif 
    804             IF( ln_subbas ) THEN 
    805                CALL histdef( numptr, "sostatl", "Salt Transport Atlantic"//TRIM(cl_comment)      ,  & 
    806                   "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    807                CALL histdef( numptr, "sostpac", "Salt Transport Pacific"//TRIM(cl_comment)      ,   & 
    808                   "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    809                CALL histdef( numptr, "sostind", "Salt Transport Indian"//TRIM(cl_comment)      ,    & 
    810                   "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    811                CALL histdef( numptr, "sostipc", "Salt Transport Pacific+Indian"//TRIM(cl_comment),  & 
    812                   "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    813             ENDIF 
    814             ! 
    815             CALL histend( numptr ) 
    816             ! 
    817          END IF 
    818 #if defined key_mpp_mpi 
    819       END IF 
    820 #endif 
    821  
    822 #if defined key_mpp_mpi 
    823       IF( MOD( itmod, nn_fptr ) == 0 .AND. l_znl_root ) THEN 
    824 #else 
    825       IF( MOD( itmod, nn_fptr ) == 0  ) THEN 
    826 #endif 
    827          niter = niter + 1 
    828  
    829          IF( ln_diaznl ) THEN  
    830             CALL histwrite( numptr, "zosrfglo", niter, sjk  (:,:,1) , ndim, ndex ) 
    831             CALL histwrite( numptr, "zotemglo", niter, tn_jk(:,:,1)  , ndim, ndex ) 
    832             CALL histwrite( numptr, "zosalglo", niter, sn_jk(:,:,1)  , ndim, ndex ) 
    833  
    834             IF (ln_subbas) THEN  
    835                CALL histwrite( numptr, "zosrfatl", niter, sjk(:,:,2), ndim_atl, ndex_atl ) 
    836                CALL histwrite( numptr, "zosrfpac", niter, sjk(:,:,3), ndim_pac, ndex_pac ) 
    837                CALL histwrite( numptr, "zosrfind", niter, sjk(:,:,4), ndim_ind, ndex_ind ) 
    838                CALL histwrite( numptr, "zosrfipc", niter, sjk(:,:,5), ndim_ipc, ndex_ipc ) 
    839  
    840                CALL histwrite( numptr, "zotematl", niter, tn_jk(:,:,2)  , ndim_atl, ndex_atl ) 
    841                CALL histwrite( numptr, "zosalatl", niter, sn_jk(:,:,2)  , ndim_atl, ndex_atl ) 
    842                CALL histwrite( numptr, "zotempac", niter, tn_jk(:,:,3)  , ndim_pac, ndex_pac ) 
    843                CALL histwrite( numptr, "zosalpac", niter, sn_jk(:,:,3)  , ndim_pac, ndex_pac ) 
    844                CALL histwrite( numptr, "zotemind", niter, tn_jk(:,:,4)  , ndim_ind, ndex_ind ) 
    845                CALL histwrite( numptr, "zosalind", niter, sn_jk(:,:,4)  , ndim_ind, ndex_ind ) 
    846                CALL histwrite( numptr, "zotemipc", niter, tn_jk(:,:,5)  , ndim_ipc, ndex_ipc ) 
    847                CALL histwrite( numptr, "zosalipc", niter, sn_jk(:,:,5)  , ndim_ipc, ndex_ipc ) 
    848             END IF 
    849          ENDIF 
    850  
    851          ! overturning outputs: 
    852          CALL histwrite( numptr, "zomsfglo", niter, v_msf(:,:,1), ndim, ndex ) 
    853          IF( ln_subbas .AND. ln_diaznl ) THEN 
    854             CALL histwrite( numptr, "zomsfatl", niter, v_msf(:,:,2) , ndim_atl_30, ndex_atl_30 ) 
    855             CALL histwrite( numptr, "zomsfpac", niter, v_msf(:,:,3) , ndim_pac_30, ndex_pac_30 ) 
    856             CALL histwrite( numptr, "zomsfind", niter, v_msf(:,:,4) , ndim_ind_30, ndex_ind_30 ) 
    857             CALL histwrite( numptr, "zomsfipc", niter, v_msf(:,:,5) , ndim_ipc_30, ndex_ipc_30 ) 
    858          ENDIF 
    859 #if defined key_diaeiv 
    860          CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv(:,:,1), ndim  , ndex   ) 
    861 #endif 
    862  
    863          ! heat transport outputs: 
    864          IF( ln_subbas ) THEN 
    865             CALL histwrite( numptr, "sohtatl", niter, htr(:,2)  , ndim_h_atl_30, ndex_h_atl_30 ) 
    866             CALL histwrite( numptr, "sohtpac", niter, htr(:,3)  , ndim_h_pac_30, ndex_h_pac_30 ) 
    867             CALL histwrite( numptr, "sohtind", niter, htr(:,4)  , ndim_h_ind_30, ndex_h_ind_30 ) 
    868             CALL histwrite( numptr, "sohtipc", niter, htr(:,5)  , ndim_h_ipc_30, ndex_h_ipc_30 ) 
    869             CALL histwrite( numptr, "sostatl", niter, str(:,2)  , ndim_h_atl_30, ndex_h_atl_30 ) 
    870             CALL histwrite( numptr, "sostpac", niter, str(:,3)  , ndim_h_pac_30, ndex_h_pac_30 ) 
    871             CALL histwrite( numptr, "sostind", niter, str(:,4)  , ndim_h_ind_30, ndex_h_ind_30 ) 
    872             CALL histwrite( numptr, "sostipc", niter, str(:,5)  , ndim_h_ipc_30, ndex_h_ipc_30 ) 
    873          ENDIF 
    874  
    875          CALL histwrite( numptr, "sophtadv", niter, htr_adv     , ndim_h, ndex_h ) 
    876          CALL histwrite( numptr, "sophtldf", niter, htr_ldf     , ndim_h, ndex_h ) 
    877          CALL histwrite( numptr, "sopstadv", niter, str_adv     , ndim_h, ndex_h ) 
    878          CALL histwrite( numptr, "sopstldf", niter, str_ldf     , ndim_h, ndex_h ) 
    879          IF( ln_ptrcomp ) THEN  
    880             CALL histwrite( numptr, "sopstove", niter, str_ove(:) , ndim_h, ndex_h ) 
    881             CALL histwrite( numptr, "sophtove", niter, htr_ove(:) , ndim_h, ndex_h ) 
    882          ENDIF 
    883 #if defined key_diaeiv 
    884          CALL histwrite( numptr, "sophteiv", niter, htr_eiv(:,1)  , ndim_h, ndex_h ) 
    885          CALL histwrite( numptr, "sopsteiv", niter, str_eiv(:,1)  , ndim_h, ndex_h ) 
    886 #endif 
    887          ! 
    888       ENDIF 
    889       ! 
    890       CALL wrk_dealloc( jpj      , zphi , zfoo ) 
    891       CALL wrk_dealloc( jpj , jpk, z_1 ) 
    892       ! 
    893   END SUBROUTINE dia_ptr_wri 
     435      ! 
     436   END FUNCTION ptr_sjk 
     437 
    894438 
    895439   !!====================================================================== 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r5038 r5620  
    4444   USE in_out_manager  ! I/O manager 
    4545   USE diadimg         ! dimg direct access file format output 
    46 <<<<<<< .working 
    47    USE diaar5, ONLY :   lk_diaar5 
    48 ======= 
    49 >>>>>>> .merge-right.r5035 
    5046   USE iom 
    5147   USE ioipsl 
     48   USE dynspg_oce, ONLY: un_adv, vn_adv ! barotropic velocities      
     49 
    5250#if defined key_lim2 
    5351   USE limwri_2  
     
    8280   !!---------------------------------------------------------------------- 
    8381   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    84    !! $Id $ 
     82   !! $Id$ 
    8583   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    8684   !!---------------------------------------------------------------------- 
     
    129127      !! 
    130128      INTEGER                      ::   ji, jj, jk              ! dummy loop indices 
     129      INTEGER                      ::   jkbot                   ! 
    131130      REAL(wp)                     ::   zztmp, zztmpx, zztmpy   !  
    132131      !! 
    133 <<<<<<< .working 
    134132      REAL(wp), POINTER, DIMENSION(:,:)   :: z2d      ! 2D workspace 
    135       REAL(wp), POINTER, DIMENSION(:,:)   :: z2ds     ! 2D workspace 
    136 ======= 
    137       REAL(wp), POINTER, DIMENSION(:,:)   :: z2d      ! 2D workspace 
    138 >>>>>>> .merge-right.r5035 
    139133      REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d      ! 3D workspace 
    140134      !!---------------------------------------------------------------------- 
     
    142136      IF( nn_timing == 1 )   CALL timing_start('dia_wri') 
    143137      !  
    144       CALL wrk_alloc( jpi , jpj      , z2d , z2ds ) 
     138      CALL wrk_alloc( jpi , jpj      , z2d ) 
    145139      CALL wrk_alloc( jpi , jpj, jpk , z3d ) 
    146140      ! 
     
    151145      ENDIF 
    152146 
    153       IF( lk_vvl ) THEN 
    154          z3d(:,:,:) = tsn(:,:,:,jp_tem) * fse3t_n(:,:,:) 
    155          CALL iom_put( "toce" , z3d                        )   ! heat content 
     147      IF( .NOT.lk_vvl ) THEN 
     148         CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 
     149         CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 
     150         CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 
     151         CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
     152      ENDIF 
     153 
     154      CALL iom_put( "ssh" , sshn )                 ! sea surface height 
     155      if( iom_use('ssh2') )   CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
     156       
     157      CALL iom_put( "toce", tsn(:,:,:,jp_tem) )    ! 3D temperature 
     158      CALL iom_put(  "sst", tsn(:,:,1,jp_tem) )    ! surface temperature 
     159      IF ( iom_use("sbt") ) THEN 
    156160         DO jj = 1, jpj 
    157161            DO ji = 1, jpi 
    158                z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * fse3t_n(ji,jj,mikt(ji,jj)) 
    159             END DO 
    160          END DO   
    161          CALL iom_put( "sst"  , z2d(:,:)                 )   ! sea surface heat content       
     162               jkbot = mbkt(ji,jj) 
     163               z2d(ji,jj) = tsn(ji,jj,jkbot,jp_tem) 
     164            END DO 
     165         END DO 
     166         CALL iom_put( "sbt", z2d )                ! bottom temperature 
     167      ENDIF 
     168       
     169      CALL iom_put( "soce", tsn(:,:,:,jp_sal) )    ! 3D salinity 
     170      CALL iom_put(  "sss", tsn(:,:,1,jp_sal) )    ! surface salinity 
     171      IF ( iom_use("sbs") ) THEN 
    162172         DO jj = 1, jpj 
    163173            DO ji = 1, jpi 
    164                z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem)**2 * fse3t_n(ji,jj,mikt(ji,jj)) 
    165             END DO 
    166          END DO   
    167          CALL iom_put( "sst2" , z2d(:,:)      )   ! sea surface content of squared temperature 
    168          z3d(:,:,:) = tsn(:,:,:,jp_sal) * fse3t_n(:,:,:)             
    169          CALL iom_put( "soce" , z3d                        )   ! salinity content 
     174               jkbot = mbkt(ji,jj) 
     175               z2d(ji,jj) = tsn(ji,jj,jkbot,jp_sal) 
     176            END DO 
     177         END DO 
     178         CALL iom_put( "sbs", z2d )                ! bottom salinity 
     179      ENDIF 
     180 
     181      IF ( iom_use("taubot") ) THEN                ! bottom stress 
     182         z2d(:,:) = 0._wp 
     183         DO jj = 2, jpjm1 
     184            DO ji = fs_2, fs_jpim1   ! vector opt. 
     185               zztmpx = (  bfrua(ji  ,jj) * un(ji  ,jj,mbku(ji  ,jj))  & 
     186                      &  + bfrua(ji-1,jj) * un(ji-1,jj,mbku(ji-1,jj))  )       
     187               zztmpy = (  bfrva(ji,  jj) * vn(ji,jj  ,mbkv(ji,jj  ))  & 
     188                      &  + bfrva(ji,jj-1) * vn(ji,jj-1,mbkv(ji,jj-1))  )  
     189               z2d(ji,jj) = rau0 * SQRT( zztmpx * zztmpx + zztmpy * zztmpy ) * tmask(ji,jj,1)  
     190               ! 
     191            ENDDO 
     192         ENDDO 
     193         CALL lbc_lnk( z2d, 'T', 1. ) 
     194         CALL iom_put( "taubot", z2d )            
     195      ENDIF 
     196          
     197      CALL iom_put( "uoce", un(:,:,:)         )    ! 3D i-current 
     198      CALL iom_put(  "ssu", un(:,:,1)         )    ! surface i-current 
     199      IF ( iom_use("sbu") ) THEN 
    170200         DO jj = 1, jpj 
    171201            DO ji = 1, jpi 
    172                z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * fse3t_n(ji,jj,mikt(ji,jj)) 
    173             END DO 
    174          END DO   
    175          CALL iom_put( "sss"  , z2d(:,:)                 )   ! sea surface salinity content 
     202               jkbot = mbku(ji,jj) 
     203               z2d(ji,jj) = un(ji,jj,jkbot) 
     204            END DO 
     205         END DO 
     206         CALL iom_put( "sbu", z2d )                ! bottom i-current 
     207      ENDIF 
     208#if defined key_dynspg_ts 
     209      CALL iom_put(  "ubar", un_adv(:,:)      )    ! barotropic i-current 
     210#else 
     211      CALL iom_put(  "ubar", un_b(:,:)        )    ! barotropic i-current 
     212#endif 
     213       
     214      CALL iom_put( "voce", vn(:,:,:)         )    ! 3D j-current 
     215      CALL iom_put(  "ssv", vn(:,:,1)         )    ! surface j-current 
     216      IF ( iom_use("sbv") ) THEN 
    176217         DO jj = 1, jpj 
    177218            DO ji = 1, jpi 
    178                z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal)**2 * fse3t_n(ji,jj,mikt(ji,jj)) 
    179             END DO 
    180          END DO   
    181          CALL iom_put( "sss2" , z2d(:,:)                 )   ! sea surface content of squared salinity 
    182       ELSE 
    183          CALL iom_put( "toce" , tsn(:,:,:,jp_tem)        )   ! temperature 
    184          IF ( iom_use("sst") ) THEN 
    185             DO jj = 1, jpj 
    186                DO ji = 1, jpi 
    187                   z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) 
    188                END DO 
    189             END DO 
    190             CALL iom_put( "sst"  , z2d(:,:)            ) ! sea surface temperature 
    191          ENDIF 
    192          IF ( iom_use("sst2") )   CALL iom_put( "sst2" , z2d(:,:) * z2d(:,:) ) ! square of sea surface temperature 
    193          CALL iom_put( "soce" , tsn(:,:,:,jp_sal)          )   ! salinity 
    194          IF ( iom_use("sss") ) THEN 
    195             DO jj = 1, jpj 
    196                DO ji = 1, jpi 
    197                   z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) 
    198                END DO 
    199             END DO 
    200             CALL iom_put( "sss"  , z2d(:,:)            ) ! sea surface salinity 
    201          ENDIF 
    202          CALL iom_put( "sss2" , z2d(:,:) * z2d(:,:) ) ! square of sea surface salinity 
    203       END IF 
    204       IF( lk_vvl .AND. (.NOT. ln_dynadv_vec) ) THEN 
    205          CALL iom_put( "uoce" , umask(:,:,:) * un(:,:,:) * fse3u_n(:,:,:) )    ! i-transport 
    206          CALL iom_put( "voce" , vmask(:,:,:) * vn(:,:,:) * fse3v_n(:,:,:) )    ! j-transport 
    207       ELSE 
    208          CALL iom_put( "uoce" , umask(:,:,:) * un(:,:,:)                  )    ! i-current 
    209          CALL iom_put( "voce" , vmask(:,:,:) * vn(:,:,:)                  )    ! j-current 
    210          IF ( iom_use("ssu") ) THEN 
    211             DO jj = 1, jpj 
    212                DO ji = 1, jpi 
    213                   z2d(ji,jj) = un(ji,jj,miku(ji,jj)) 
    214                END DO 
    215             END DO 
    216             CALL iom_put( "ssu"   , z2d                                    )    ! i-current 
    217          ENDIF 
    218          IF ( iom_use("ssv") ) THEN 
    219             DO jj = 1, jpj 
    220                DO ji = 1, jpi 
    221                   z2d(ji,jj) = vn(ji,jj,mikv(ji,jj)) 
    222                END DO 
    223             END DO 
    224             CALL iom_put( "ssv"   , z2d                                    )    ! j-current 
    225          ENDIF 
    226       ENDIF 
    227       CALL iom_put(    "avt"  , avt                        )    ! T vert. eddy diff. coef. 
    228       CALL iom_put(    "avm"  , avmu                       )    ! T vert. eddy visc. coef. 
    229       IF( lk_zdfddm ) THEN 
    230          CALL iom_put( "avs" , fsavs(:,:,:)                          )    ! S vert. eddy diff. coef. 
    231       ENDIF 
    232  
    233       IF ( iom_use("sstgrad2") .OR. iom_use("sstgrad2") ) THEN 
     219               jkbot = mbkv(ji,jj) 
     220               z2d(ji,jj) = vn(ji,jj,jkbot) 
     221            END DO 
     222         END DO 
     223         CALL iom_put( "sbv", z2d )                ! bottom j-current 
     224      ENDIF 
     225#if defined key_dynspg_ts 
     226      CALL iom_put(  "vbar", vn_adv(:,:)      )    ! barotropic j-current 
     227#else 
     228      CALL iom_put(  "vbar", vn_b(:,:)        )    ! barotropic j-current 
     229#endif 
     230 
     231      CALL iom_put( "woce", wn )                   ! vertical velocity 
     232      IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN   ! vertical mass transport & its square value 
     233         ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 
     234         z2d(:,:) = rau0 * e12t(:,:) 
     235         DO jk = 1, jpk 
     236            z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) 
     237         END DO 
     238         CALL iom_put( "w_masstr" , z3d )   
     239         IF( iom_use('w_masstr2') )   CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 
     240      ENDIF 
     241 
     242      CALL iom_put( "avt" , avt                        )    ! T vert. eddy diff. coef. 
     243      CALL iom_put( "avm" , avmu                       )    ! T vert. eddy visc. coef. 
     244      CALL iom_put( "avs" , fsavs(:,:,:)               )    ! S vert. eddy diff. coef. (useful only with key_zdfddm) 
     245 
     246      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 
    234247         DO jj = 2, jpjm1                                    ! sst gradient 
    235248            DO ji = fs_2, fs_jpim1   ! vector opt. 
     
    243256         CALL lbc_lnk( z2d, 'T', 1. ) 
    244257         CALL iom_put( "sstgrad2",  z2d               )    ! square of module of sst gradient 
    245          !CDIR NOVERRCHK< 
    246258         z2d(:,:) = SQRT( z2d(:,:) ) 
    247259         CALL iom_put( "sstgrad" ,  z2d               )    ! module of sst gradient 
     
    252264         z2d(:,:)  = 0._wp  
    253265         DO jk = 1, jpkm1 
    254             DO jj = 2, jpjm1 
    255                DO ji = fs_2, fs_jpim1   ! vector opt. 
     266            DO jj = 1, jpj 
     267               DO ji = 1, jpi 
    256268                  z2d(ji,jj) = z2d(ji,jj) + fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 
    257269               END DO 
    258270            END DO 
    259271         END DO 
    260          CALL lbc_lnk( z2d, 'T', 1. ) 
    261272         CALL iom_put( "heatc", (rau0 * rcp) * z2d )    ! vertically integrated heat content (J/m2) 
    262273      ENDIF 
    263274 
    264 <<<<<<< .working 
    265       ! clem: heat and salt content 
    266       z2d(:,:)  = 0._wp  
    267       z2ds(:,:) = 0._wp  
    268       DO jk = 1, jpkm1 
    269          DO jj = 2, jpjm1 
    270             DO ji = fs_2, fs_jpim1   ! vector opt. 
    271                z2d(ji,jj) = z2d(ji,jj) + rau0 * rcp * fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 
    272                z2ds(ji,jj) = z2ds(ji,jj) + rau0 * fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 
    273             END DO 
    274          END DO 
    275       END DO 
    276       CALL lbc_lnk( z2d, 'T', 1. ) 
    277       CALL lbc_lnk( z2ds, 'T', 1. ) 
    278       CALL iom_put( "heatc", z2d )    ! vertically integrated heat content (J/m2) 
    279       CALL iom_put( "saltc", z2ds )   ! vertically integrated salt content (PSU*kg/m2) 
    280        
    281  
    282       IF( lk_diaar5 ) THEN 
    283 ======= 
    284275      IF( iom_use("saltc") ) THEN 
    285276         z2d(:,:)  = 0._wp  
    286277         DO jk = 1, jpkm1 
    287             DO jj = 2, jpjm1 
    288                DO ji = fs_2, fs_jpim1   ! vector opt. 
     278            DO jj = 1, jpj 
     279               DO ji = 1, jpi 
    289280                  z2d(ji,jj) = z2d(ji,jj) + fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 
    290281               END DO 
    291282            END DO 
    292283         END DO 
    293          CALL lbc_lnk( z2d, 'T', 1. ) 
    294284         CALL iom_put( "saltc", rau0 * z2d )   ! vertically integrated salt content (PSU*kg/m2) 
    295285      ENDIF 
     
    319309          
    320310      IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
    321 >>>>>>> .merge-right.r5035 
    322311         z3d(:,:,jpk) = 0.e0 
    323312         DO jk = 1, jpkm1 
     
    325314         END DO 
    326315         CALL iom_put( "u_masstr", z3d )                  ! mass transport in i-direction 
    327 <<<<<<< .working 
    328  
    329          zztmp = 0.5 * rcp 
    330 ======= 
    331316      ENDIF 
    332317       
    333318      IF( iom_use("u_heattr") ) THEN 
    334 >>>>>>> .merge-right.r5035 
    335319         z2d(:,:) = 0.e0  
    336          z2ds(:,:) = 0.e0  
    337320         DO jk = 1, jpkm1 
    338321            DO jj = 2, jpjm1 
    339322               DO ji = fs_2, fs_jpim1   ! vector opt. 
    340323                  z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 
    341                   z2ds(ji,jj) = z2ds(ji,jj) + z3d(ji,jj,jk) * 0.5_wp * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) 
    342324               END DO 
    343325            END DO 
    344326         END DO 
    345327         CALL lbc_lnk( z2d, 'U', -1. ) 
    346 <<<<<<< .working 
    347          CALL lbc_lnk( z2ds, 'U', -1. ) 
    348          CALL iom_put( "u_heattr", z2d )                  ! heat transport in i-direction 
    349 ======= 
    350328         CALL iom_put( "u_heattr", (0.5 * rcp) * z2d )    ! heat transport in i-direction 
    351329      ENDIF 
     
    353331      IF( iom_use("u_salttr") ) THEN 
    354332         z2d(:,:) = 0.e0  
    355 >>>>>>> .merge-right.r5035 
    356          CALL iom_put( "u_salttr", z2ds )                 ! salt transport in i-direction 
    357  
    358          z3d(:,:,jpk) = 0.e0 
    359333         DO jk = 1, jpkm1 
    360 <<<<<<< .working 
    361             z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * fse3v(:,:,jk) * vmask(:,:,jk) 
    362 ======= 
    363334            DO jj = 2, jpjm1 
    364335               DO ji = fs_2, fs_jpim1   ! vector opt. 
     
    366337               END DO 
    367338            END DO 
    368 >>>>>>> .merge-right.r5035 
    369339         END DO 
    370340         CALL lbc_lnk( z2d, 'U', -1. ) 
     
    379349         END DO 
    380350         CALL iom_put( "v_masstr", z3d )                  ! mass transport in j-direction 
    381 <<<<<<< .working 
    382  
    383 ======= 
    384351      ENDIF 
    385352       
    386353      IF( iom_use("v_heattr") ) THEN 
    387 >>>>>>> .merge-right.r5035 
    388354         z2d(:,:) = 0.e0  
    389          z2ds(:,:) = 0.e0  
    390355         DO jk = 1, jpkm1 
    391356            DO jj = 2, jpjm1 
    392357               DO ji = fs_2, fs_jpim1   ! vector opt. 
    393358                  z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 
    394                   z2ds(ji,jj) = z2ds(ji,jj) + z3d(ji,jj,jk) * 0.5_wp * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) 
    395359               END DO 
    396360            END DO 
    397361         END DO 
    398362         CALL lbc_lnk( z2d, 'V', -1. ) 
    399 <<<<<<< .working 
    400          CALL lbc_lnk( z2ds, 'V', -1. ) 
    401          CALL iom_put( "v_heattr", z2d )                  !  heat transport in j-direction 
    402          CALL iom_put( "v_salttr", z2ds )                 !  salt transport in j-direction 
    403 ======= 
    404363         CALL iom_put( "v_heattr", (0.5 * rcp) * z2d )    !  heat transport in j-direction 
    405 >>>>>>> .merge-right.r5035 
    406364      ENDIF 
    407365 
     
    419377      ENDIF 
    420378      ! 
    421       CALL wrk_dealloc( jpi , jpj      , z2d , z2ds ) 
     379      CALL wrk_dealloc( jpi , jpj      , z2d ) 
    422380      CALL wrk_dealloc( jpi , jpj, jpk , z3d ) 
    423381      ! 
     
    480438      zdt = rdt 
    481439      IF( nacc == 1 ) zdt = rdtmin 
    482       IF( ln_mskland )   THEN   ;   clop = "only(x)"   ! put 1.e+20 on land (very expensive!!) 
    483       ELSE                      ;   clop = "x"         ! no use of the mask value (require less cpu time) 
    484       ENDIF 
     440      clop = "x"         ! no use of the mask value (require less cpu time and otherwise the model crashes) 
    485441#if defined key_diainstant 
    486442      zsto = nwrite * zdt 
     
    682638         ENDIF 
    683639 
    684          IF( .NOT. lk_cpl ) THEN 
     640         IF( .NOT. ln_cpl ) THEN 
    685641            CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping"         , "W/m2"   ,   &  ! qrp 
    686642               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
     
    691647         ENDIF 
    692648 
    693          IF( lk_cpl .AND. nn_ice <= 1 ) THEN 
     649         IF( ln_cpl .AND. nn_ice <= 1 ) THEN 
    694650            CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping"         , "W/m2"   ,   &  ! qrp 
    695651               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
     
    714670#endif 
    715671 
    716          IF( lk_cpl .AND. nn_ice == 2 ) THEN 
     672         IF( ln_cpl .AND. nn_ice == 2 ) THEN 
    717673            CALL histdef( nid_T,"soicetem" , "Ice Surface Temperature"            , "K"      ,   &  ! tn_ice 
    718674               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
     
    869825      ENDIF 
    870826 
    871       IF( .NOT. lk_cpl ) THEN 
     827      IF( .NOT. ln_cpl ) THEN 
    872828         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    873829         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
     
    875831         CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping 
    876832      ENDIF 
    877       IF( lk_cpl .AND. nn_ice <= 1 ) THEN 
     833      IF( ln_cpl .AND. nn_ice <= 1 ) THEN 
    878834         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    879835         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
     
    891847#endif 
    892848 
    893       IF( lk_cpl .AND. nn_ice == 2 ) THEN 
     849      IF( ln_cpl .AND. nn_ice == 2 ) THEN 
    894850         CALL histwrite( nid_T, "soicetem", it, tn_ice(:,:,1) , ndim_hT, ndex_hT )   ! surf. ice temperature 
    895851         CALL histwrite( nid_T, "soicealb", it, alb_ice(:,:,1), ndim_hT, ndex_hT )   ! ice albedo 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90

    r4162 r5620  
    7272      !!---------------------------------------------------------------------- 
    7373      INTEGER ::   jc            ! dummy loop indices 
     74      INTEGER :: isrow           ! local index 
    7475      !!---------------------------------------------------------------------- 
    7576       
     
    9192         CASE ( 1 )                                  ! ORCA_R1 configuration 
    9293            !                                        ! ======================= 
     94            ! This dirty section will be suppressed by simplification process: 
     95            ! all this will come back in input files 
     96            ! Currently these hard-wired indices relate to configuration with 
     97            ! extend grid (jpjglo=332) 
     98            isrow = 332 - jpjglo 
     99            ! 
    93100            ncsnr(1)   = 1    ; ncstt(1)   = 0           ! Caspian Sea 
    94             ncsi1(1)   = 332  ; ncsj1(1)   = 203 
    95             ncsi2(1)   = 344  ; ncsj2(1)   = 235 
     101            ncsi1(1)   = 332  ; ncsj1(1)   = 243 - isrow 
     102            ncsi2(1)   = 344  ; ncsj2(1)   = 275 - isrow 
    96103            ncsir(1,1) = 1    ; ncsjr(1,1) = 1 
    97104            !                                         
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90

    r5038 r5620  
    7373      !!---------------------------------------------------------------------- 
    7474      ! 
     75      ! max number of seconds between each restart 
     76      IF( REAL( nitend - nit000 + 1 ) * rdt > REAL( HUGE( nsec1jan000 ) ) ) THEN 
     77         CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ',   & 
     78            &           'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) 
     79      ENDIF 
    7580      ! all calendar staff is based on the fact that MOD( rday, rdttra(1) ) == 0 
    7681      IF( MOD( rday     , rdttra(1) ) /= 0. )   CALL ctl_stop( 'the time step must devide the number of second of in a day' ) 
     
    238243               nday_year = 1 
    239244               nsec_year = ndt05 
    240                IF( nsec1jan000 >= 2 * (2**30 - nsecd * nyear_len(1) / 2 ) ) THEN   ! test integer 4 max value 
    241                   CALL ctl_stop( 'The number of seconds between Jan. 1st 00h of nit000 year and Jan. 1st 00h ',   & 
    242                      &           'of the current year is exceeding the INTEGER 4 max VALUE: 2^31-1 -> 68.09 years in seconds', & 
    243                      & 'You must do a restart at higher frequency (or remove this STOP and recompile everything in I8)' ) 
    244                ENDIF 
    245245               nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1) 
    246246               IF( nleapy == 1 )   CALL day_mth 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r5038 r5620  
    162162   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  gphit, gphiu   !: latitude  of t-, u-, v- and f-points (degre) 
    163163   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  gphiv, gphif   !: 
    164    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1t, e2t       !: horizontal scale factors at t-point (m) 
    165    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1u, e2u       !: horizontal scale factors at u-point (m) 
    166    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1v, e2v       !: horizontal scale factors at v-point (m) 
    167    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1f, e2f       !: horizontal scale factors at f-point (m) 
     164   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1t, e2t, r1_e1t, r1_e2t   !: horizontal scale factors and inverse at t-point (m) 
     165   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1u, e2u, r1_e1u, r1_e2u   !: horizontal scale factors and inverse at u-point (m) 
     166   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1v, e2v, r1_e1v, r1_e2v   !: horizontal scale factors and inverse at v-point (m) 
     167   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1f, e2f, r1_e1f, r1_e2f   !: horizontal scale factors and inverse at f-point (m) 
    168168   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  e1e2t          !: surface at t-point (m2) 
    169169   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ff             !: coriolis factor (2.*omega*sin(yphi) ) (s-1) 
     
    262262 
    263263   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask   !: land/ocean mask at T-, U-, V- and F-pts 
     264   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask        !: land/ocean mask at WT-, WU- and WV-pts 
    264265 
    265266   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   tpol, fpol          !: north fold mask (jperio= 3 or 4) 
     
    332333   INTEGER FUNCTION dom_oce_alloc() 
    333334      !!---------------------------------------------------------------------- 
    334       INTEGER, DIMENSION(11) :: ierr 
     335      INTEGER, DIMENSION(12) :: ierr 
    335336      !!---------------------------------------------------------------------- 
    336337      ierr(:) = 0 
     
    345346         &      tpol(jpiglo)  , fpol(jpiglo)                               , STAT=ierr(2) ) 
    346347         ! 
    347       ALLOCATE( glamt(jpi,jpj) , gphit(jpi,jpj) , e1t(jpi,jpj) , e2t(jpi,jpj) ,                      &  
    348          &      glamu(jpi,jpj) , gphiu(jpi,jpj) , e1u(jpi,jpj) , e2u(jpi,jpj) ,                      &   
    349          &      glamv(jpi,jpj) , gphiv(jpi,jpj) , e1v(jpi,jpj) , e2v(jpi,jpj) , e1e2t(jpi,jpj) ,     &   
    350          &      glamf(jpi,jpj) , gphif(jpi,jpj) , e1f(jpi,jpj) , e2f(jpi,jpj) , ff   (jpi,jpj) , STAT=ierr(3) )      
     348      ALLOCATE( glamt(jpi,jpj) , gphit(jpi,jpj) , e1t(jpi,jpj) , e2t(jpi,jpj) , r1_e1t(jpi,jpj) , r1_e2t(jpi,jpj) ,   &  
     349         &      glamu(jpi,jpj) , gphiu(jpi,jpj) , e1u(jpi,jpj) , e2u(jpi,jpj) , r1_e1u(jpi,jpj) , r1_e2u(jpi,jpj) ,   &   
     350         &      glamv(jpi,jpj) , gphiv(jpi,jpj) , e1v(jpi,jpj) , e2v(jpi,jpj) , r1_e1v(jpi,jpj) , r1_e2v(jpi,jpj) ,   &   
     351         &      glamf(jpi,jpj) , gphif(jpi,jpj) , e1f(jpi,jpj) , e2f(jpi,jpj) , r1_e1f(jpi,jpj) , r1_e2f(jpi,jpj) ,   & 
     352         &      e1e2t(jpi,jpj) , ff   (jpi,jpj) , STAT=ierr(3) )      
    351353         ! 
    352354      ALLOCATE( gdep3w_0(jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0 (jpi,jpj,jpk) ,                         & 
     
    400402         &      vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk), STAT=ierr(11) ) 
    401403 
     404      ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) ) 
     405 
    402406#if defined key_noslip_accurate 
    403       ALLOCATE( npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), STAT=ierr(11) ) 
     407      ALLOCATE( npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), STAT=ierr(12) ) 
    404408#endif 
    405409      ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90

    r5038 r5620  
    135135      !!---------------------------------------------------------------------- 
    136136      USE ioipsl 
    137       NAMELIST/namrun/ nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl,   & 
     137      NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,               & 
     138         &             nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl,   & 
    138139         &             nn_it000, nn_itend  , nn_date0    , nn_leapy     , nn_istate , nn_stock ,   & 
    139          &             nn_write, ln_dimgnnn, ln_mskland  , ln_clobber   , nn_chunksz, nn_euler 
     140         &             nn_write, ln_dimgnnn, ln_mskland  , ln_cfmeta    , ln_clobber, nn_chunksz, nn_euler 
    140141      NAMELIST/namdom/ nn_bathy, rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin,   & 
    141142         &             nn_acc   , rn_atfp     , rn_rdt      , rn_rdtmin ,                  & 
     
    169170         WRITE(numout,*) '      experiment name for output      cn_exp     = ', cn_exp 
    170171         WRITE(numout,*) '      file prefix restart input       cn_ocerst_in= ', cn_ocerst_in 
     172         WRITE(numout,*) '      restart input directory         cn_ocerst_indir= ', cn_ocerst_indir 
    171173         WRITE(numout,*) '      file prefix restart output      cn_ocerst_out= ', cn_ocerst_out 
     174         WRITE(numout,*) '      restart output directory        cn_ocerst_outdir= ', cn_ocerst_outdir 
    172175         WRITE(numout,*) '      restart logical                 ln_rstart  = ', ln_rstart 
    173176         WRITE(numout,*) '      start with forward time step    nn_euler   = ', nn_euler 
     
    178181         WRITE(numout,*) '      leap year calendar (0/1)        nn_leapy   = ', nn_leapy 
    179182         WRITE(numout,*) '      initial state output            nn_istate  = ', nn_istate 
    180          WRITE(numout,*) '      frequency of restart file       nn_stock   = ', nn_stock 
     183         IF( ln_rst_list ) THEN 
     184            WRITE(numout,*) '      list of restart dump times      nn_stocklist   =', nn_stocklist 
     185         ELSE 
     186            WRITE(numout,*) '      frequency of restart file       nn_stock   = ', nn_stock 
     187         ENDIF 
    181188         WRITE(numout,*) '      frequency of output file        nn_write   = ', nn_write 
    182189         WRITE(numout,*) '      multi file dimgout              ln_dimgnnn = ', ln_dimgnnn 
    183190         WRITE(numout,*) '      mask land points                ln_mskland = ', ln_mskland 
     191         WRITE(numout,*) '      additional CF standard metadata ln_cfmeta  = ', ln_cfmeta 
    184192         WRITE(numout,*) '      overwrite an existing file      ln_clobber = ', ln_clobber 
    185193         WRITE(numout,*) '      NetCDF chunksize (bytes)        nn_chunksz = ', nn_chunksz 
     
    195203      ninist = nn_istate 
    196204      nstock = nn_stock 
     205      nstocklist = nn_stocklist 
    197206      nwrite = nn_write 
    198207      neuler = nn_euler 
    199       IF ( neuler == 1 .AND. .NOT.ln_rstart ) THEN 
     208      IF ( neuler == 1 .AND. .NOT. ln_rstart ) THEN 
    200209         WRITE(ctmp1,*) 'ln_rstart =.FALSE., nn_euler is forced to 0 ' 
    201210         CALL ctl_warn( ctmp1 ) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90

    r5038 r5620  
    105105      REAL(wp) ::   zlam1, zcos_alpha, zim1 , zjm1 , ze1, ze1deg 
    106106      REAL(wp) ::   zphi1, zsin_alpha, zim05, zjm05 
     107      INTEGER  ::   isrow                ! index for ORCA1 starting row 
     108 
    107109      !!---------------------------------------------------------------------- 
    108110      ! 
     
    159161         IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN    ! ORCA R1 configuration 
    160162            !                                             ! ===================== 
    161  
    162             ii0 = 281   ;   ii1 = 282        ! Gibraltar Strait (e2u = 20 km) 
    163             ij0 = 200   ;   ij1 = 200   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  20.e3 
     163            ! This dirty section will be suppressed by simplification process: all this will come back in input files 
     164            ! Currently these hard-wired indices relate to configuration with 
     165            ! extend grid (jpjglo=332) 
     166            ! which had a grid-size of 362x292. 
     167            !  
     168            isrow = 332 - jpjglo 
     169            ! 
     170            ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait (e2u = 20 km) 
     171            ij0 = 241 - isrow   ;   ij1 = 241 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  20.e3 
    164172            IF(lwp) WRITE(numout,*) 
    165173            IF(lwp) WRITE(numout,*) '             orca_r1: Gibraltar : e2u reduced to 20 km' 
    166174 
    167             ii0 = 314   ;   ii1 = 315        ! Bhosporus Strait (e2u = 10 km) 
    168             ij0 = 208   ;   ij1 = 208   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  10.e3 
     175            ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait (e2u = 10 km) 
     176            ij0 = 248 - isrow   ;   ij1 = 248 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  10.e3 
    169177            IF(lwp) WRITE(numout,*) 
    170178            IF(lwp) WRITE(numout,*) '             orca_r1: Bhosporus : e2u reduced to 10 km' 
    171179 
    172             ii0 =  44   ;   ii1 =  44        ! Lombok Strait (e1v = 13 km) 
    173             ij0 = 124   ;   ij1 = 125   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  13.e3 
     180            ii0 =  44           ;   ii1 =  44        ! Lombok Strait (e1v = 13 km) 
     181            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  13.e3 
    174182            IF(lwp) WRITE(numout,*) 
    175183            IF(lwp) WRITE(numout,*) '             orca_r1: Lombok : e1v reduced to 10 km' 
    176184 
    177             ii0 =  48   ;   ii1 =  48        ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] 
    178             ij0 = 124   ;   ij1 = 125   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  8.e3 
     185            ii0 =  48           ;   ii1 =  48        ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] 
     186            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  8.e3 
    179187            IF(lwp) WRITE(numout,*) 
    180188            IF(lwp) WRITE(numout,*) '             orca_r1: Sumba : e1v reduced to 8 km' 
    181189 
    182             ii0 =  53   ;   ii1 =  53        ! Ombai Strait (e1v = 13 km) 
    183             ij0 = 124   ;   ij1 = 125   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 
     190            ii0 =  53           ;   ii1 =  53        ! Ombai Strait (e1v = 13 km) 
     191            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 
    184192            IF(lwp) WRITE(numout,*) 
    185193            IF(lwp) WRITE(numout,*) '             orca_r1: Ombai : e1v reduced to 13 km' 
    186194 
    187             ii0 =  56   ;   ii1 =  56        ! Timor Passage (e1v = 20 km) 
    188             ij0 = 124   ;   ij1 = 125   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 
     195            ii0 =  56           ;   ii1 =  56        ! Timor Passage (e1v = 20 km) 
     196            ij0 = 164 - isrow   ;   ij1 = 145 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 
    189197            IF(lwp) WRITE(numout,*) 
    190198            IF(lwp) WRITE(numout,*) '             orca_r1: Timor Passage : e1v reduced to 20 km' 
    191199 
    192             ii0 =  55   ;   ii1 =  55        ! West Halmahera Strait (e1v = 30 km) 
    193             ij0 = 141   ;   ij1 = 142   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 
     200            ii0 =  55           ;   ii1 =  55        ! West Halmahera Strait (e1v = 30 km) 
     201            ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 
    194202            IF(lwp) WRITE(numout,*) 
    195203            IF(lwp) WRITE(numout,*) '             orca_r1: W Halmahera : e1v reduced to 30 km' 
    196204 
    197             ii0 =  58   ;   ii1 =  58        ! East Halmahera Strait (e1v = 50 km) 
    198             ij0 = 141   ;   ij1 = 142   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 
     205            ii0 =  58           ;   ii1 =  58        ! East Halmahera Strait (e1v = 50 km) 
     206            ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 
    199207            IF(lwp) WRITE(numout,*) 
    200208            IF(lwp) WRITE(numout,*) '             orca_r1: E Halmahera : e1v reduced to 50 km' 
    201  
    202             ! 
    203  
    204             ! 
    205             ! 
    206209            ! 
    207210            ! 
     
    471474      re2u_e1u(:,:) = e2u(:,:) / e1u(:,:) 
    472475      re1v_e2v(:,:) = e1v(:,:) / e2v(:,:) 
     476      r1_e1t  (:,:) = 1._wp    / e1t(:,:) 
     477      r1_e1u  (:,:) = 1._wp    / e1u(:,:) 
     478      r1_e1v  (:,:) = 1._wp    / e1v(:,:) 
     479      r1_e1f  (:,:) = 1._wp    / e1f(:,:) 
     480      r1_e2t  (:,:) = 1._wp    / e2t(:,:) 
     481      r1_e2u  (:,:) = 1._wp    / e2u(:,:) 
     482      r1_e2v  (:,:) = 1._wp    / e2v(:,:) 
     483      r1_e2f  (:,:) = 1._wp    / e2f(:,:) 
    473484 
    474485      ! Control printing : Grid informations (if not restart) 
     
    616627      CALL iom_open( 'coordinates', inum ) 
    617628       
    618       CALL iom_get( inum, jpdom_data, 'glamt', glamt ) 
    619       CALL iom_get( inum, jpdom_data, 'glamu', glamu ) 
    620       CALL iom_get( inum, jpdom_data, 'glamv', glamv ) 
    621       CALL iom_get( inum, jpdom_data, 'glamf', glamf ) 
    622        
    623       CALL iom_get( inum, jpdom_data, 'gphit', gphit ) 
    624       CALL iom_get( inum, jpdom_data, 'gphiu', gphiu ) 
    625       CALL iom_get( inum, jpdom_data, 'gphiv', gphiv ) 
    626       CALL iom_get( inum, jpdom_data, 'gphif', gphif ) 
    627        
    628       CALL iom_get( inum, jpdom_data, 'e1t', e1t ) 
    629       CALL iom_get( inum, jpdom_data, 'e1u', e1u ) 
    630       CALL iom_get( inum, jpdom_data, 'e1v', e1v ) 
    631       CALL iom_get( inum, jpdom_data, 'e1f', e1f ) 
    632        
    633       CALL iom_get( inum, jpdom_data, 'e2t', e2t ) 
    634       CALL iom_get( inum, jpdom_data, 'e2u', e2u ) 
    635       CALL iom_get( inum, jpdom_data, 'e2v', e2v ) 
    636       CALL iom_get( inum, jpdom_data, 'e2f', e2f ) 
     629      CALL iom_get( inum, jpdom_data, 'glamt', glamt, lrowattr=ln_use_jattr ) 
     630      CALL iom_get( inum, jpdom_data, 'glamu', glamu, lrowattr=ln_use_jattr ) 
     631      CALL iom_get( inum, jpdom_data, 'glamv', glamv, lrowattr=ln_use_jattr ) 
     632      CALL iom_get( inum, jpdom_data, 'glamf', glamf, lrowattr=ln_use_jattr ) 
     633       
     634      CALL iom_get( inum, jpdom_data, 'gphit', gphit, lrowattr=ln_use_jattr ) 
     635      CALL iom_get( inum, jpdom_data, 'gphiu', gphiu, lrowattr=ln_use_jattr ) 
     636      CALL iom_get( inum, jpdom_data, 'gphiv', gphiv, lrowattr=ln_use_jattr ) 
     637      CALL iom_get( inum, jpdom_data, 'gphif', gphif, lrowattr=ln_use_jattr ) 
     638       
     639      CALL iom_get( inum, jpdom_data, 'e1t', e1t, lrowattr=ln_use_jattr ) 
     640      CALL iom_get( inum, jpdom_data, 'e1u', e1u, lrowattr=ln_use_jattr ) 
     641      CALL iom_get( inum, jpdom_data, 'e1v', e1v, lrowattr=ln_use_jattr ) 
     642      CALL iom_get( inum, jpdom_data, 'e1f', e1f, lrowattr=ln_use_jattr ) 
     643       
     644      CALL iom_get( inum, jpdom_data, 'e2t', e2t, lrowattr=ln_use_jattr ) 
     645      CALL iom_get( inum, jpdom_data, 'e2u', e2u, lrowattr=ln_use_jattr ) 
     646      CALL iom_get( inum, jpdom_data, 'e2v', e2v, lrowattr=ln_use_jattr ) 
     647      CALL iom_get( inum, jpdom_data, 'e2f', e2f, lrowattr=ln_use_jattr ) 
    637648       
    638649      CALL iom_close( inum ) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r5038 r5620  
    134134      INTEGER  ::   ijf, ijl, ij0, ij1       !   -       - 
    135135      INTEGER  ::   ios 
     136      INTEGER  ::   isrow                    ! index for ORCA1 starting row 
    136137      INTEGER , POINTER, DIMENSION(:,:) ::  imsk 
    137138      REAL(wp), POINTER, DIMENSION(:,:) ::  zwf 
     
    281282      CALL lbc_lnk( fmask_i, 'F', 1._wp ) 
    282283 
     284      ! 3. Ocean/land mask at wu-, wv- and w points  
     285      !---------------------------------------------- 
     286      wmask (:,:,1) = tmask(:,:,1) ! ???????? 
     287      wumask(:,:,1) = umask(:,:,1) ! ???????? 
     288      wvmask(:,:,1) = vmask(:,:,1) ! ???????? 
     289      DO jk=2,jpk 
     290         wmask (:,:,jk)=tmask(:,:,jk) * tmask(:,:,jk-1) 
     291         wumask(:,:,jk)=umask(:,:,jk) * umask(:,:,jk-1)    
     292         wvmask(:,:,jk)=vmask(:,:,jk) * vmask(:,:,jk-1) 
     293      END DO 
    283294 
    284295      ! 4. ocean/land mask for the elliptic equation 
     
    391402      IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN   ! ORCA R1 configuration 
    392403         !                                                 ! Increased lateral friction near of some straits 
     404         ! This dirty section will be suppressed by simplification process: 
     405         ! all this will come back in input files 
     406         ! Currently these hard-wired indices relate to configuration with 
     407         ! extend grid (jpjglo=332) 
     408         ! 
     409         isrow = 332 - jpjglo 
     410         ! 
    393411         IF(lwp) WRITE(numout,*) 
    394412         IF(lwp) WRITE(numout,*) '   orca_r1: increase friction near the following straits : ' 
    395413         IF(lwp) WRITE(numout,*) '      Gibraltar ' 
    396          ii0 = 283   ;   ii1 = 284        ! Gibraltar Strait  
    397          ij0 = 200   ;   ij1 = 200   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 2._wp   
     414         ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait  
     415         ij0 = 241 - isrow   ;   ij1 = 241 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    398416 
    399417         IF(lwp) WRITE(numout,*) '      Bhosporus ' 
    400          ii0 = 314   ;   ii1 = 315        ! Bhosporus Strait  
    401          ij0 = 208   ;   ij1 = 208   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 2._wp   
     418         ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait  
     419         ij0 = 248 - isrow   ;   ij1 = 248 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    402420 
    403421         IF(lwp) WRITE(numout,*) '      Makassar (Top) ' 
    404          ii0 =  48   ;   ii1 =  48        ! Makassar Strait (Top)  
    405          ij0 = 149   ;   ij1 = 150   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 3._wp   
     422         ii0 =  48           ;   ii1 =  48        ! Makassar Strait (Top)  
     423         ij0 = 189 - isrow   ;   ij1 = 190 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    406424 
    407425         IF(lwp) WRITE(numout,*) '      Lombok ' 
    408          ii0 =  44   ;   ii1 =  44        ! Lombok Strait  
    409          ij0 = 124   ;   ij1 = 125   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 2._wp   
     426         ii0 =  44           ;   ii1 =  44        ! Lombok Strait  
     427         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    410428 
    411429         IF(lwp) WRITE(numout,*) '      Ombai ' 
    412          ii0 =  53   ;   ii1 =  53        ! Ombai Strait  
    413          ij0 = 124   ;   ij1 = 125   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 2._wp   
     430         ii0 =  53           ;   ii1 =  53        ! Ombai Strait  
     431         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    414432 
    415433         IF(lwp) WRITE(numout,*) '      Timor Passage ' 
    416          ii0 =  56   ;   ii1 =  56        ! Timor Passage  
    417          ij0 = 124   ;   ij1 = 125   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 2._wp   
     434         ii0 =  56           ;   ii1 =  56        ! Timor Passage  
     435         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    418436 
    419437         IF(lwp) WRITE(numout,*) '      West Halmahera ' 
    420          ii0 =  58   ;   ii1 =  58        ! West Halmahera Strait  
    421          ij0 = 141   ;   ij1 = 142   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 3._wp   
     438         ii0 =  58           ;   ii1 =  58        ! West Halmahera Strait  
     439         ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    422440 
    423441         IF(lwp) WRITE(numout,*) '      East Halmahera ' 
    424          ii0 =  55   ;   ii1 =  55        ! East Halmahera Strait  
    425          ij0 = 141   ;   ij1 = 142   ;   fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) = 3._wp   
     442         ii0 =  55           ;   ii1 =  55        ! East Halmahera Strait  
     443         ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    426444         ! 
    427445      ENDIF 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r5038 r5620  
    88   !!            3.3  !  2011-10  (M. Leclair) totally rewrote domvvl: 
    99   !!                                          vvl option includes z_star and z_tilde coordinates 
     10   !!            3.6  !  2014-11  (P. Mathiot) add ice shelf capability 
    1011   !!---------------------------------------------------------------------- 
    1112   !!   'key_vvl'                              variable volume 
     
    125126      INTEGER ::   ji,jj,jk 
    126127      INTEGER ::   ii0, ii1, ij0, ij1 
     128      REAL(wp)::   zcoef 
    127129      !!---------------------------------------------------------------------- 
    128130      IF( nn_timing == 1 )  CALL timing_start('dom_vvl_init') 
     
    164166      ! t- and w- points depth 
    165167      ! ---------------------- 
     168      ! set the isf depth as it is in the initial step 
    166169      fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 
    167170      fsdepw_n(:,:,1) = 0.0_wp 
     
    169172      fsdept_b(:,:,1) = 0.5_wp * fse3w_b(:,:,1) 
    170173      fsdepw_b(:,:,1) = 0.0_wp 
    171       DO jj = 1,jpj 
    172          DO ji = 1,jpi 
    173             DO jk = 2,mikt(ji,jj)-1 
    174                fsdept_n(ji,jj,jk) = gdept_0(ji,jj,jk) 
    175                fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    176                fsde3w_n(ji,jj,jk) = gdept_0(ji,jj,jk) - sshn(ji,jj) 
    177                fsdept_b(ji,jj,jk) = gdept_0(ji,jj,jk) 
    178                fsdepw_b(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    179             END DO 
    180             IF (mikt(ji,jj) .GT. 1) THEN 
    181                jk = mikt(ji,jj) 
    182                fsdept_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * fse3w_n(ji,jj,jk) 
    183                fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    184                fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk  ) - sshn   (ji,jj) 
    185                fsdept_b(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * fse3w_b(ji,jj,jk) 
    186                fsdepw_b(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    187             END IF 
    188             DO jk = mikt(ji,jj)+1, jpk 
    189                fsdept_n(ji,jj,jk) = fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk) 
     174 
     175      DO jk = 2, jpk 
     176         DO jj = 1,jpj 
     177            DO ji = 1,jpi 
     178              !    zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))   ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
     179                                                     ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 
     180                                                     ! 0.5 where jk = mikt   
     181               zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 
    190182               fsdepw_n(ji,jj,jk) = fsdepw_n(ji,jj,jk-1) + fse3t_n(ji,jj,jk-1) 
    191                fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk  ) - sshn   (ji,jj) 
    192                fsdept_b(ji,jj,jk) = fsdept_b(ji,jj,jk-1) + fse3w_b(ji,jj,jk) 
     183               fsdept_n(ji,jj,jk) =      zcoef  * ( fsdepw_n(ji,jj,jk  ) + 0.5 * fse3w_n(ji,jj,jk))  & 
     184                   &                + (1-zcoef) * ( fsdept_n(ji,jj,jk-1) +       fse3w_n(ji,jj,jk))  
     185               fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk) - sshn(ji,jj) 
    193186               fsdepw_b(ji,jj,jk) = fsdepw_b(ji,jj,jk-1) + fse3t_b(ji,jj,jk-1) 
     187               fsdept_b(ji,jj,jk) =      zcoef  * ( fsdepw_b(ji,jj,jk  ) + 0.5 * fse3w_b(ji,jj,jk))  & 
     188                   &                + (1-zcoef) * ( fsdept_b(ji,jj,jk-1) +       fse3w_b(ji,jj,jk))  
    194189            END DO 
    195190         END DO 
     
    588583      INTEGER, INTENT( in )               :: kt       ! time step 
    589584      !! * Local declarations 
    590       REAL(wp), POINTER, DIMENSION(:,:,:) :: z_e3t_def 
    591585      INTEGER                             :: ji,jj,jk       ! dummy loop indices 
     586      REAL(wp)                            :: zcoef 
    592587      !!---------------------------------------------------------------------- 
    593588 
    594589      IF( nn_timing == 1 )  CALL timing_start('dom_vvl_sf_swp') 
    595       ! 
    596       CALL wrk_alloc( jpi, jpj, jpk, z_e3t_def                ) 
    597590      ! 
    598591      IF( kt == nit000 )   THEN 
     
    638631      ! t- and w- points depth 
    639632      ! ---------------------- 
     633      ! set the isf depth as it is in the initial step 
    640634      fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 
    641635      fsdepw_n(:,:,1) = 0.0_wp 
    642636      fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 
    643       DO jj = 1,jpj 
    644          DO ji = 1,jpi 
    645             DO jk = 2,mikt(ji,jj)-1 
    646                fsdept_n(ji,jj,jk) = gdept_0(ji,jj,jk) 
    647                fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    648                fsde3w_n(ji,jj,jk) = gdept_0(ji,jj,jk) - sshn(ji,jj) 
    649             END DO 
    650             IF (mikt(ji,jj) .GT. 1) THEN 
    651                jk = mikt(ji,jj) 
    652                fsdept_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * fse3w_n(ji,jj,jk) 
    653                fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    654                fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk  ) - sshn   (ji,jj) 
    655             END IF 
    656             DO jk = mikt(ji,jj)+1, jpk 
    657                fsdept_n(ji,jj,jk) = fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk) 
     637 
     638      DO jk = 2, jpk 
     639         DO jj = 1,jpj 
     640            DO ji = 1,jpi 
     641              !    zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))   ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
     642                                                                 ! 1 for jk = mikt 
     643               zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 
    658644               fsdepw_n(ji,jj,jk) = fsdepw_n(ji,jj,jk-1) + fse3t_n(ji,jj,jk-1) 
    659                fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk  ) - sshn   (ji,jj) 
     645               fsdept_n(ji,jj,jk) =      zcoef  * ( fsdepw_n(ji,jj,jk  ) + 0.5 * fse3w_n(ji,jj,jk))  & 
     646                   &                + (1-zcoef) * ( fsdept_n(ji,jj,jk-1) +       fse3w_n(ji,jj,jk))  
     647               fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk) - sshn(ji,jj) 
    660648            END DO 
    661649         END DO 
    662650      END DO 
     651 
    663652      ! Local depth and Inverse of the local depth of the water column at u- and v- points 
    664653      ! ---------------------------------------------------------------------------------- 
     
    679668      ! Write outputs 
    680669      ! ============= 
    681       z_e3t_def(:,:,:) = ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 
    682       CALL iom_put( "cellthc" , fse3t_n  (:,:,:) ) 
     670      CALL iom_put(     "e3t" , fse3t_n  (:,:,:) ) 
     671      CALL iom_put(     "e3u" , fse3u_n  (:,:,:) ) 
     672      CALL iom_put(     "e3v" , fse3v_n  (:,:,:) ) 
     673      CALL iom_put(     "e3w" , fse3w_n  (:,:,:) ) 
    683674      CALL iom_put( "tpt_dep" , fsde3w_n (:,:,:) ) 
    684       CALL iom_put( "e3tdef"  , z_e3t_def(:,:,:) ) 
     675      IF( iom_use("e3tdef") )   & 
     676         CALL iom_put( "e3tdef"  , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
    685677 
    686678      ! write restart file 
    687679      ! ================== 
    688680      IF( lrst_oce ) CALL dom_vvl_rst( kt, 'WRITE' ) 
    689       ! 
    690       CALL wrk_dealloc( jpi, jpj, jpk, z_e3t_def ) 
    691681      ! 
    692682      IF( nn_timing == 1 )  CALL timing_stop('dom_vvl_sf_swp') 
     
    10491039      INTEGER ::   ji, jj, jk                                          ! dummy loop indices 
    10501040      INTEGER ::   ij0, ij1, ii0, ii1                                  ! dummy loop indices 
     1041      INTEGER ::   isrow                                               ! index for ORCA1 starting row 
    10511042      !! acc 
    10521043      !! Hmm with the time splitting these "fixes" seem to do more harm than good. Temporarily disabled for 
     
    11321123      IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN    ! ORCA R1 configuration 
    11331124         !                                             ! ===================== 
    1134          ! 
    1135          ii0 = 281   ;   ii1 = 282        ! Gibraltar Strait (e2u was modified) 
    1136          ij0 = 200   ;   ij1 = 200 
     1125         ! This dirty section will be suppressed by simplification process: 
     1126         ! all this will come back in input files 
     1127         ! Currently these hard-wired indices relate to configuration with 
     1128         ! extend grid (jpjglo=332) 
     1129         ! which had a grid-size of 362x292. 
     1130         isrow = 332 - jpjglo 
     1131         ! 
     1132         ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait (e2u was modified) 
     1133         ij0 = 241 - isrow   ;   ij1 = 241 - isrow 
    11371134         DO jk = 1, jpkm1 
    11381135            DO jj = mj0(ij0), mj1(ij1) 
     
    11541151         END DO 
    11551152         ! 
    1156          ii0 = 314   ;   ii1 = 315        ! Bhosporus Strait (e2u was modified) 
    1157          ij0 = 208   ;   ij1 = 208 
     1153         ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait (e2u was modified) 
     1154         ij0 = 248 - isrow   ;   ij1 = 248 - isrow 
    11581155         DO jk = 1, jpkm1 
    11591156            DO jj = mj0(ij0), mj1(ij1) 
     
    11751172         END DO 
    11761173         ! 
    1177          ii0 =  44   ;   ii1 =  44        ! Lombok Strait (e1v was modified) 
    1178          ij0 = 124   ;   ij1 = 125 
     1174         ii0 =  44           ;   ii1 =  44        ! Lombok Strait (e1v was modified) 
     1175         ij0 = 164 - isrow   ;   ij1 = 165 - isrow 
    11791176         DO jk = 1, jpkm1 
    11801177            DO jj = mj0(ij0), mj1(ij1) 
     
    11911188         END DO 
    11921189         ! 
    1193          ii0 =  48   ;   ii1 =  48        ! Sumba Strait (e1v was modified) [closed from bathy_11 on] 
    1194          ij0 = 124   ;   ij1 = 125 
     1190         ii0 =  48           ;   ii1 =  48        ! Sumba Strait (e1v was modified) [closed from bathy_11 on] 
     1191         ij0 = 164 - isrow   ;   ij1 = 165 - isrow 
    11951192         DO jk = 1, jpkm1 
    11961193            DO jj = mj0(ij0), mj1(ij1) 
     
    12071204         END DO 
    12081205         ! 
    1209          ii0 =  53   ;   ii1 =  53        ! Ombai Strait (e1v was modified) 
    1210          ij0 = 124   ;   ij1 = 125 
     1206         ii0 =  53          ;   ii1 =  53        ! Ombai Strait (e1v was modified) 
     1207         ij0 = 164 - isrow  ;   ij1 = 165  - isrow   
    12111208         DO jk = 1, jpkm1 
    12121209            DO jj = mj0(ij0), mj1(ij1) 
     
    12231220         END DO 
    12241221         ! 
    1225          ii0 =  56   ;   ii1 =  56        ! Timor Passage (e1v was modified) 
    1226          ij0 = 124   ;   ij1 = 125 
     1222         ii0 =  56            ;   ii1 =  56        ! Timor Passage (e1v was modified) 
     1223         ij0 = 164 - isrow    ;   ij1 = 165  - isrow   
    12271224         DO jk = 1, jpkm1 
    12281225            DO jj = mj0(ij0), mj1(ij1) 
     
    12391236         END DO 
    12401237         ! 
    1241          ii0 =  55   ;   ii1 =  55        ! West Halmahera Strait (e1v was modified) 
    1242          ij0 = 141   ;   ij1 = 142 
     1238         ii0 =  55            ;   ii1 =  55        ! West Halmahera Strait (e1v was modified) 
     1239         ij0 = 181 - isrow    ;   ij1 = 182 - isrow   
    12431240         DO jk = 1, jpkm1 
    12441241            DO jj = mj0(ij0), mj1(ij1) 
     
    12551252         END DO 
    12561253         ! 
    1257          ii0 =  58   ;   ii1 =  58        ! East Halmahera Strait (e1v was modified) 
    1258          ij0 = 141   ;   ij1 = 142 
     1254         ii0 =  58            ;   ii1 =  58        ! East Halmahera Strait (e1v was modified) 
     1255         ij0 = 181 - isrow    ;   ij1 = 182 - isrow   
    12591256         DO jk = 1, jpkm1 
    12601257            DO jj = mj0(ij0), mj1(ij1) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r5038 r5620  
    215215         CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d )  !    ! stretched system 
    216216         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 
     217         CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 )      
     218         CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 ) 
    217219      ENDIF 
    218220       
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r5038 r5620  
    1717   !!            3.4  ! 2012-08  (J. Siddorn) added Siddorn and Furner stretching function 
    1818   !!            3.4  ! 2012-12  (R. Bourdalle-Badie and G. Reffray)  modify C1D case   
     19   !!            3.6  ! 2014-11  (P. Mathiot and C. Harris) add ice shelf capabilitye   
    1920   !!---------------------------------------------------------------------- 
    2021 
     
    3536   USE oce               ! ocean variables 
    3637   USE dom_oce           ! ocean domain 
    37    USE sbc_oce           ! surface variable (isf) 
    3838   USE closea            ! closed seas 
    3939   USE c1d               ! 1D vertical configuration 
     
    298298      ENDIF 
    299299 
     300      IF ( ln_isfcav ) THEN 
    300301! need to be like this to compute the pressure gradient with ISF. If not, level beneath the ISF are not aligned (sum(e3t) /= depth) 
    301302! define e3t_0 and e3w_0 as the differences between gdept and gdepw respectively 
    302       DO jk = 1, jpkm1 
    303          e3t_1d(jk) = gdepw_1d(jk+1)-gdepw_1d(jk)  
    304       END DO 
    305       e3t_1d(jpk) = e3t_1d(jpk-1)   ! we don't care because this level is masked in NEMO 
    306  
    307       DO jk = 2, jpk 
    308          e3w_1d(jk) = gdept_1d(jk) - gdept_1d(jk-1)  
    309       END DO 
    310       e3w_1d(1  ) = 2._wp * (gdept_1d(1) - gdepw_1d(1))  
     303         DO jk = 1, jpkm1 
     304            e3t_1d(jk) = gdepw_1d(jk+1)-gdepw_1d(jk)  
     305         END DO 
     306         e3t_1d(jpk) = e3t_1d(jpk-1)   ! we don't care because this level is masked in NEMO 
     307 
     308         DO jk = 2, jpk 
     309            e3w_1d(jk) = gdept_1d(jk) - gdept_1d(jk-1)  
     310         END DO 
     311         e3w_1d(1  ) = 2._wp * (gdept_1d(1) - gdepw_1d(1))  
     312      END IF 
    311313 
    312314!!gm BUG in s-coordinate this does not work! 
     
    365367      INTEGER  ::   ji, jj, jl, jk            ! dummy loop indices 
    366368      INTEGER  ::   inum                      ! temporary logical unit 
     369      INTEGER  ::   ierror                    ! error flag 
    367370      INTEGER  ::   ii_bump, ij_bump, ih      ! bump center position 
    368371      INTEGER  ::   ii0, ii1, ij0, ij1, ik    ! local indices 
    369372      REAL(wp) ::   r_bump , h_bump , h_oce   ! bump characteristics  
    370373      REAL(wp) ::   zi, zj, zh, zhmin         ! local scalars 
    371       INTEGER , POINTER, DIMENSION(:,:) ::   idta   ! global domain integer data 
    372       REAL(wp), POINTER, DIMENSION(:,:) ::   zdta   ! global domain scalar data 
     374      INTEGER , ALLOCATABLE, DIMENSION(:,:) ::   idta   ! global domain integer data 
     375      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdta   ! global domain scalar data 
    373376      !!---------------------------------------------------------------------- 
    374377      ! 
    375378      IF( nn_timing == 1 )  CALL timing_start('zgr_bat') 
    376       ! 
    377       CALL wrk_alloc( jpidta, jpjdta, idta ) 
    378       CALL wrk_alloc( jpidta, jpjdta, zdta ) 
    379379      ! 
    380380      IF(lwp) WRITE(numout,*) 
     
    385385         !                                            ! ================== ! 
    386386         !                                            ! global domain level and meter bathymetry (idta,zdta) 
     387         ! 
     388         ALLOCATE( idta(jpidta,jpjdta), STAT=ierror ) 
     389         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'zgr_bat: unable to allocate idta array' ) 
     390         ALLOCATE( zdta(jpidta,jpjdta), STAT=ierror ) 
     391         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'zgr_bat: unable to allocate zdta array' ) 
    387392         ! 
    388393         IF( ntopo == 0 ) THEN                        ! flat basin 
     
    468473         misfdep(:,:)=1 
    469474         ! 
    470          ! (ISF) TODO build ice draft netcdf file for isomip and build the corresponding part of code 
    471          IF( cp_cfg == "isomip" ) THEN  
    472            !  
    473            risfdep(:,:)=200.e0  
    474            misfdep(:,:)=1  
    475            ij0 = 1 ; ij1 = 40  
    476            DO jj = mj0(ij0), mj1(ij1)  
    477               risfdep(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp  
    478                 END DO  
    479             WHERE( bathy(:,:) <= 0._wp )  risfdep(:,:) = 0._wp  
    480            !  
    481          ELSEIF ( cp_cfg == "isomip2" ) THEN 
    482          !  
    483             risfdep(:,:)=0.e0 
    484             misfdep(:,:)=1 
    485             ij0 = 1 ; ij1 = 40 
    486             DO jj = mj0(ij0), mj1(ij1) 
    487                risfdep(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp 
    488             END DO 
    489             WHERE( bathy(:,:) <= 0._wp )  risfdep(:,:) = 0._wp 
    490          END IF 
     475         DEALLOCATE( idta, zdta ) 
    491476         ! 
    492477         !                                            ! ================ ! 
     
    529514         IF( ln_zps .OR. ln_sco )   THEN              ! zps or sco : read meter bathymetry 
    530515            CALL iom_open ( 'bathy_meter.nc', inum )  
    531             CALL iom_get  ( inum, jpdom_data, 'Bathymetry', bathy ) 
     516            IF ( ln_isfcav ) THEN 
     517               CALL iom_get  ( inum, jpdom_data, 'Bathymetry_isf', bathy, lrowattr=.false. ) 
     518            ELSE 
     519               CALL iom_get  ( inum, jpdom_data, 'Bathymetry'    , bathy, lrowattr=ln_use_jattr  ) 
     520            END IF 
    532521            CALL iom_close( inum ) 
    533             !   
     522            !                                                 
    534523            risfdep(:,:)=0._wp          
    535524            misfdep(:,:)=1              
     
    579568      IF ( .not. ln_sco ) THEN                                !==  set a minimum depth  ==! 
    580569         ! patch to avoid case bathy = ice shelf draft and bathy between 0 and zhmin 
    581          WHERE (bathy == risfdep) 
    582             bathy   = 0.0_wp ; risfdep = 0.0_wp 
    583          END WHERE 
     570         IF ( ln_isfcav ) THEN 
     571            WHERE (bathy == risfdep) 
     572               bathy   = 0.0_wp ; risfdep = 0.0_wp 
     573            END WHERE 
     574         END IF 
    584575         ! end patch 
    585576         IF( rn_hmin < 0._wp ) THEN    ;   ik = - INT( rn_hmin )                                      ! from a nb of level 
     
    592583         IF(lwp) write(numout,*) 'Minimum ocean depth: ', zhmin, ' minimum number of ocean levels : ', ik 
    593584      ENDIF 
    594       ! 
    595       CALL wrk_dealloc( jpidta, jpjdta, idta ) 
    596       CALL wrk_dealloc( jpidta, jpjdta, zdta ) 
    597585      ! 
    598586      IF( nn_timing == 1 )  CALL timing_stop('zgr_bat') 
     
    959947      !!---------------------------------------------------------------------- 
    960948      !! 
     949      INTEGER  ::   ji, jj, jk       ! dummy loop indices 
     950      INTEGER  ::   ik, it, ikb, ikt ! temporary integers 
     951      LOGICAL  ::   ll_print         ! Allow  control print for debugging 
     952      REAL(wp) ::   ze3tp , ze3wp    ! Last ocean level thickness at T- and W-points 
     953      REAL(wp) ::   zdepwp, zdepth   ! Ajusted ocean depth to avoid too small e3t 
     954      REAL(wp) ::   zmax             ! Maximum depth 
     955      REAL(wp) ::   zdiff            ! temporary scalar 
     956      REAL(wp) ::   zrefdep          ! temporary scalar 
     957      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zprt 
     958      !!--------------------------------------------------------------------- 
     959      ! 
     960      IF( nn_timing == 1 )  CALL timing_start('zgr_zps') 
     961      ! 
     962      CALL wrk_alloc( jpi, jpj, jpk, zprt ) 
     963      ! 
     964      IF(lwp) WRITE(numout,*) 
     965      IF(lwp) WRITE(numout,*) '    zgr_zps : z-coordinate with partial steps' 
     966      IF(lwp) WRITE(numout,*) '    ~~~~~~~ ' 
     967      IF(lwp) WRITE(numout,*) '              mbathy is recomputed : bathy_level file is NOT used' 
     968 
     969      ll_print = .FALSE.                   ! Local variable for debugging 
     970       
     971      IF(lwp .AND. ll_print) THEN          ! control print of the ocean depth 
     972         WRITE(numout,*) 
     973         WRITE(numout,*) 'dom_zgr_zps:  bathy (in hundred of meters)' 
     974         CALL prihre( bathy, jpi, jpj, 1,jpi, 1, 1, jpj, 1, 1.e-2, numout ) 
     975      ENDIF 
     976 
     977 
     978      ! bathymetry in level (from bathy_meter) 
     979      ! =================== 
     980      zmax = gdepw_1d(jpk) + e3t_1d(jpk)        ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) 
     981      bathy(:,:) = MIN( zmax ,  bathy(:,:) )    ! bounded value of bathy (min already set at the end of zgr_bat) 
     982      WHERE( bathy(:,:) == 0._wp )   ;   mbathy(:,:) = 0       ! land  : set mbathy to 0 
     983      ELSE WHERE                     ;   mbathy(:,:) = jpkm1   ! ocean : initialize mbathy to the max ocean level 
     984      END WHERE 
     985 
     986      ! Compute mbathy for ocean points (i.e. the number of ocean levels) 
     987      ! find the number of ocean levels such that the last level thickness 
     988      ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where 
     989      ! e3t_1d is the reference level thickness 
     990      DO jk = jpkm1, 1, -1 
     991         zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 
     992         WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth )   mbathy(:,:) = jk-1 
     993      END DO 
     994 
     995      IF ( ln_isfcav ) CALL zgr_isf 
     996 
     997      ! Scale factors and depth at T- and W-points 
     998      DO jk = 1, jpk                        ! intitialization to the reference z-coordinate 
     999         gdept_0(:,:,jk) = gdept_1d(jk) 
     1000         gdepw_0(:,:,jk) = gdepw_1d(jk) 
     1001         e3t_0  (:,:,jk) = e3t_1d  (jk) 
     1002         e3w_0  (:,:,jk) = e3w_1d  (jk) 
     1003      END DO 
     1004      !  
     1005      DO jj = 1, jpj 
     1006         DO ji = 1, jpi 
     1007            ik = mbathy(ji,jj) 
     1008            IF( ik > 0 ) THEN               ! ocean point only 
     1009               ! max ocean level case 
     1010               IF( ik == jpkm1 ) THEN 
     1011                  zdepwp = bathy(ji,jj) 
     1012                  ze3tp  = bathy(ji,jj) - gdepw_1d(ik) 
     1013                  ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) 
     1014                  e3t_0(ji,jj,ik  ) = ze3tp 
     1015                  e3t_0(ji,jj,ik+1) = ze3tp 
     1016                  e3w_0(ji,jj,ik  ) = ze3wp 
     1017                  e3w_0(ji,jj,ik+1) = ze3tp 
     1018                  gdepw_0(ji,jj,ik+1) = zdepwp 
     1019                  gdept_0(ji,jj,ik  ) = gdept_1d(ik-1) + ze3wp 
     1020                  gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp 
     1021                  ! 
     1022               ELSE                         ! standard case 
     1023                  IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN  ;   gdepw_0(ji,jj,ik+1) = bathy(ji,jj) 
     1024                  ELSE                                       ;   gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 
     1025                  ENDIF 
     1026!gm Bug?  check the gdepw_1d 
     1027                  !       ... on ik 
     1028                  gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) )   & 
     1029                     &                             * ((gdept_1d(     ik  ) - gdepw_1d(ik) )   & 
     1030                     &                             / ( gdepw_1d(     ik+1) - gdepw_1d(ik) )) 
     1031                  e3t_0  (ji,jj,ik) = e3t_1d  (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) )   &  
     1032                     &                             / ( gdepw_1d(      ik+1) - gdepw_1d(ik) )  
     1033                  e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) )   & 
     1034                     &                     * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) 
     1035                  !       ... on ik+1 
     1036                  e3w_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
     1037                  e3t_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
     1038                  gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) 
     1039               ENDIF 
     1040            ENDIF 
     1041         END DO 
     1042      END DO 
     1043      ! 
     1044      it = 0 
     1045      DO jj = 1, jpj 
     1046         DO ji = 1, jpi 
     1047            ik = mbathy(ji,jj) 
     1048            IF( ik > 0 ) THEN               ! ocean point only 
     1049               e3tp (ji,jj) = e3t_0(ji,jj,ik) 
     1050               e3wp (ji,jj) = e3w_0(ji,jj,ik) 
     1051               ! test 
     1052               zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik  ) 
     1053               IF( zdiff <= 0._wp .AND. lwp ) THEN  
     1054                  it = it + 1 
     1055                  WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj 
     1056                  WRITE(numout,*) ' bathy = ', bathy(ji,jj) 
     1057                  WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 
     1058                  WRITE(numout,*) ' e3tp    = ', e3t_0  (ji,jj,ik), ' e3wp    = ', e3w_0  (ji,jj,ik  ) 
     1059               ENDIF 
     1060            ENDIF 
     1061         END DO 
     1062      END DO 
     1063      ! 
     1064      IF ( ln_isfcav ) THEN 
     1065      ! (ISF) Definition of e3t, u, v, w for ISF case 
     1066         DO jj = 1, jpj  
     1067            DO ji = 1, jpi  
     1068               ik = misfdep(ji,jj)  
     1069               IF( ik > 1 ) THEN               ! ice shelf point only  
     1070                  IF( risfdep(ji,jj) < gdepw_1d(ik) )  risfdep(ji,jj)= gdepw_1d(ik)  
     1071                  gdepw_0(ji,jj,ik) = risfdep(ji,jj)  
     1072!gm Bug?  check the gdepw_0  
     1073               !       ... on ik  
     1074                  gdept_0(ji,jj,ik) = gdepw_1d(ik+1) - ( gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) )   &  
     1075                     &                               * ( gdepw_1d(ik+1) - gdept_1d(ik)      )   &  
     1076                     &                               / ( gdepw_1d(ik+1) - gdepw_1d(ik)      )  
     1077                  e3t_0  (ji,jj,ik  ) = gdepw_1d(ik+1) - gdepw_0(ji,jj,ik)  
     1078                  e3w_0  (ji,jj,ik+1) = gdept_1d(ik+1) - gdept_0(ji,jj,ik) 
     1079 
     1080                  IF( ik + 1 == mbathy(ji,jj) ) THEN               ! ice shelf point only (2 cell water column)  
     1081                     e3w_0  (ji,jj,ik+1) = gdept_0(ji,jj,ik+1) - gdept_0(ji,jj,ik)  
     1082                  ENDIF  
     1083               !       ... on ik / ik-1  
     1084                  e3w_0  (ji,jj,ik  ) = 2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik))  
     1085                  e3t_0  (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1) 
     1086! The next line isn't required and doesn't affect results - included for consistency with bathymetry code  
     1087                  gdept_0(ji,jj,ik-1) = gdept_1d(ik-1) 
     1088               ENDIF  
     1089            END DO  
     1090         END DO  
     1091      !  
     1092         it = 0  
     1093         DO jj = 1, jpj  
     1094            DO ji = 1, jpi  
     1095               ik = misfdep(ji,jj)  
     1096               IF( ik > 1 ) THEN               ! ice shelf point only  
     1097                  e3tp (ji,jj) = e3t_0(ji,jj,ik  )  
     1098                  e3wp (ji,jj) = e3w_0(ji,jj,ik+1 )  
     1099               ! test  
     1100                  zdiff= gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik  )  
     1101                  IF( zdiff <= 0. .AND. lwp ) THEN   
     1102                     it = it + 1  
     1103                     WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj  
     1104                     WRITE(numout,*) ' risfdep = ', risfdep(ji,jj)  
     1105                     WRITE(numout,*) ' gdept = ', gdept_0(ji,jj,ik), ' gdepw = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff  
     1106                     WRITE(numout,*) ' e3tp  = ', e3tp(ji,jj), ' e3wp  = ', e3wp(ji,jj)  
     1107                  ENDIF  
     1108               ENDIF  
     1109            END DO  
     1110         END DO  
     1111      END IF 
     1112      ! END (ISF) 
     1113 
     1114      ! Scale factors and depth at U-, V-, UW and VW-points 
     1115      DO jk = 1, jpk                        ! initialisation to z-scale factors 
     1116         e3u_0 (:,:,jk) = e3t_1d(jk) 
     1117         e3v_0 (:,:,jk) = e3t_1d(jk) 
     1118         e3uw_0(:,:,jk) = e3w_1d(jk) 
     1119         e3vw_0(:,:,jk) = e3w_1d(jk) 
     1120      END DO 
     1121      DO jk = 1,jpk                         ! Computed as the minimum of neighbooring scale factors 
     1122         DO jj = 1, jpjm1 
     1123            DO ji = 1, fs_jpim1   ! vector opt. 
     1124               e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) 
     1125               e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) 
     1126               e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) 
     1127               e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) 
     1128            END DO 
     1129         END DO 
     1130      END DO 
     1131      IF ( ln_isfcav ) THEN 
     1132      ! (ISF) define e3uw (adapted for 2 cells in the water column) 
     1133         DO jj = 2, jpjm1  
     1134            DO ji = 2, fs_jpim1   ! vector opt.  
     1135               ikb = MAX(mbathy (ji,jj),mbathy (ji+1,jj)) 
     1136               ikt = MAX(misfdep(ji,jj),misfdep(ji+1,jj)) 
     1137               IF (ikb == ikt+1) e3uw_0(ji,jj,ikb) =  MIN( gdept_0(ji,jj,ikb  ), gdept_0(ji+1,jj  ,ikb  ) ) & 
     1138                                       &            - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji+1,jj  ,ikb-1) ) 
     1139               ikb = MAX(mbathy (ji,jj),mbathy (ji,jj+1)) 
     1140               ikt = MAX(misfdep(ji,jj),misfdep(ji,jj+1)) 
     1141               IF (ikb == ikt+1) e3vw_0(ji,jj,ikb) =  MIN( gdept_0(ji,jj,ikb  ), gdept_0(ji  ,jj+1,ikb  ) ) & 
     1142                                       &            - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji  ,jj+1,ikb-1) ) 
     1143            END DO 
     1144         END DO 
     1145      END IF 
     1146 
     1147      CALL lbc_lnk( e3u_0 , 'U', 1._wp )   ;   CALL lbc_lnk( e3uw_0, 'U', 1._wp )   ! lateral boundary conditions 
     1148      CALL lbc_lnk( e3v_0 , 'V', 1._wp )   ;   CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 
     1149      ! 
     1150      DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
     1151         WHERE( e3u_0 (:,:,jk) == 0._wp )   e3u_0 (:,:,jk) = e3t_1d(jk) 
     1152         WHERE( e3v_0 (:,:,jk) == 0._wp )   e3v_0 (:,:,jk) = e3t_1d(jk) 
     1153         WHERE( e3uw_0(:,:,jk) == 0._wp )   e3uw_0(:,:,jk) = e3w_1d(jk) 
     1154         WHERE( e3vw_0(:,:,jk) == 0._wp )   e3vw_0(:,:,jk) = e3w_1d(jk) 
     1155      END DO 
     1156       
     1157      ! Scale factor at F-point 
     1158      DO jk = 1, jpk                        ! initialisation to z-scale factors 
     1159         e3f_0(:,:,jk) = e3t_1d(jk) 
     1160      END DO 
     1161      DO jk = 1, jpk                        ! Computed as the minimum of neighbooring V-scale factors 
     1162         DO jj = 1, jpjm1 
     1163            DO ji = 1, fs_jpim1   ! vector opt. 
     1164               e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) 
     1165            END DO 
     1166         END DO 
     1167      END DO 
     1168      CALL lbc_lnk( e3f_0, 'F', 1._wp )       ! Lateral boundary conditions 
     1169      ! 
     1170      DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
     1171         WHERE( e3f_0(:,:,jk) == 0._wp )   e3f_0(:,:,jk) = e3t_1d(jk) 
     1172      END DO 
     1173!!gm  bug ? :  must be a do loop with mj0,mj1 
     1174      !  
     1175      e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:)     ! we duplicate factor scales for jj = 1 and jj = 2 
     1176      e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:)  
     1177      e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:)  
     1178      e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:)  
     1179      e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:)  
     1180 
     1181      ! Control of the sign 
     1182      IF( MINVAL( e3t_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3t_0 <= 0' ) 
     1183      IF( MINVAL( e3w_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3w_0 <= 0' ) 
     1184      IF( MINVAL( gdept_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdept_0 <  0' ) 
     1185      IF( MINVAL( gdepw_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdepw_0 <  0' ) 
     1186      
     1187      ! Compute gdep3w_0 (vertical sum of e3w) 
     1188      IF ( ln_isfcav ) THEN ! if cavity 
     1189         WHERE (misfdep == 0) misfdep = 1 
     1190         DO jj = 1,jpj 
     1191            DO ji = 1,jpi 
     1192               gdep3w_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1) 
     1193               DO jk = 2, misfdep(ji,jj) 
     1194                  gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
     1195               END DO 
     1196               IF (misfdep(ji,jj) .GE. 2) gdep3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5_wp * e3w_0(ji,jj,misfdep(ji,jj)) 
     1197               DO jk = misfdep(ji,jj) + 1, jpk 
     1198                  gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
     1199               END DO 
     1200            END DO 
     1201         END DO 
     1202      ELSE ! no cavity 
     1203         gdep3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) 
     1204         DO jk = 2, jpk 
     1205            gdep3w_0(:,:,jk) = gdep3w_0(:,:,jk-1) + e3w_0(:,:,jk) 
     1206         END DO 
     1207      END IF 
     1208      !                                               ! ================= ! 
     1209      IF(lwp .AND. ll_print) THEN                     !   Control print   ! 
     1210         !                                            ! ================= ! 
     1211         DO jj = 1,jpj 
     1212            DO ji = 1, jpi 
     1213               ik = MAX( mbathy(ji,jj), 1 ) 
     1214               zprt(ji,jj,1) = e3t_0   (ji,jj,ik) 
     1215               zprt(ji,jj,2) = e3w_0   (ji,jj,ik) 
     1216               zprt(ji,jj,3) = e3u_0   (ji,jj,ik) 
     1217               zprt(ji,jj,4) = e3v_0   (ji,jj,ik) 
     1218               zprt(ji,jj,5) = e3f_0   (ji,jj,ik) 
     1219               zprt(ji,jj,6) = gdep3w_0(ji,jj,ik) 
     1220            END DO 
     1221         END DO 
     1222         WRITE(numout,*) 
     1223         WRITE(numout,*) 'domzgr e3t(mbathy)'      ;   CALL prihre(zprt(:,:,1),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1224         WRITE(numout,*) 
     1225         WRITE(numout,*) 'domzgr e3w(mbathy)'      ;   CALL prihre(zprt(:,:,2),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1226         WRITE(numout,*) 
     1227         WRITE(numout,*) 'domzgr e3u(mbathy)'      ;   CALL prihre(zprt(:,:,3),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1228         WRITE(numout,*) 
     1229         WRITE(numout,*) 'domzgr e3v(mbathy)'      ;   CALL prihre(zprt(:,:,4),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1230         WRITE(numout,*) 
     1231         WRITE(numout,*) 'domzgr e3f(mbathy)'      ;   CALL prihre(zprt(:,:,5),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1232         WRITE(numout,*) 
     1233         WRITE(numout,*) 'domzgr gdep3w(mbathy)'   ;   CALL prihre(zprt(:,:,6),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1234      ENDIF   
     1235      ! 
     1236      CALL wrk_dealloc( jpi, jpj, jpk, zprt ) 
     1237      ! 
     1238      IF( nn_timing == 1 )  CALL timing_stop('zgr_zps') 
     1239      ! 
     1240   END SUBROUTINE zgr_zps 
     1241 
     1242   SUBROUTINE zgr_isf 
     1243      !!---------------------------------------------------------------------- 
     1244      !!                    ***  ROUTINE zgr_isf  *** 
     1245      !!    
     1246      !! ** Purpose :   check the bathymetry in levels 
     1247      !!    
     1248      !! ** Method  :   THe water column have to contained at least 2 cells 
     1249      !!                Bathymetry and isfdraft are modified (dig/close) to respect 
     1250      !!                this criterion. 
     1251      !!                  
     1252      !!    
     1253      !! ** Action  : - test compatibility between isfdraft and bathy  
     1254      !!              - bathy and isfdraft are modified 
     1255      !!---------------------------------------------------------------------- 
     1256      !!    
    9611257      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    9621258      INTEGER  ::   ik, it           ! temporary integers 
     
    9691265      REAL(wp) ::   zdiff            ! temporary scalar 
    9701266      REAL(wp) ::   zrefdep          ! temporary scalar 
    971       REAL(wp) ::   zbathydiff, zrisfdepdiff  
    972       REAL(wp), POINTER, DIMENSION(:,:)   ::   zrisfdep, zbathy, zmask   ! 3D workspace (ISH) 
    973       INTEGER , POINTER, DIMENSION(:,:)   ::   zmbathy, zmisfdep   ! 3D workspace (ISH) 
    974       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zprt 
     1267      REAL(wp) ::   zbathydiff, zrisfdepdiff  ! isf temporary scalar 
     1268      REAL(wp), POINTER, DIMENSION(:,:)   ::   zrisfdep, zbathy, zmask   ! 2D workspace (ISH) 
     1269      INTEGER , POINTER, DIMENSION(:,:)   ::   zmbathy, zmisfdep         ! 2D workspace (ISH) 
    9751270      !!--------------------------------------------------------------------- 
    9761271      ! 
    977       IF( nn_timing == 1 )  CALL timing_start('zgr_zps') 
    978       ! 
    979       CALL wrk_alloc( jpi, jpj, jpk, zprt ) 
     1272      IF( nn_timing == 1 )  CALL timing_start('zgr_isf') 
     1273      ! 
    9801274      CALL wrk_alloc( jpi, jpj, zbathy, zmask, zrisfdep) 
    981       CALL wrk_alloc( jpi, jpj, zmbathy, zmisfdep) 
    982       ! 
    983       IF(lwp) WRITE(numout,*) 
    984       IF(lwp) WRITE(numout,*) '    zgr_zps : z-coordinate with partial steps' 
    985       IF(lwp) WRITE(numout,*) '    ~~~~~~~ ' 
    986       IF(lwp) WRITE(numout,*) '              mbathy is recomputed : bathy_level file is NOT used' 
    987  
    988       ll_print = .FALSE.                   ! Local variable for debugging 
    989        
    990       IF(lwp .AND. ll_print) THEN          ! control print of the ocean depth 
    991          WRITE(numout,*) 
    992          WRITE(numout,*) 'dom_zgr_zps:  bathy (in hundred of meters)' 
    993          CALL prihre( bathy, jpi, jpj, 1,jpi, 1, 1, jpj, 1, 1.e-2, numout ) 
    994       ENDIF 
    995  
    996       ! bathymetry in level (from bathy_meter) 
    997       ! =================== 
    998       zmax = gdepw_1d(jpk) + e3t_1d(jpk)        ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) 
    999       bathy(:,:) = MIN( zmax ,  bathy(:,:) )    ! bounded value of bathy (min already set at the end of zgr_bat) 
    1000       WHERE( bathy(:,:) == 0._wp )   ;   mbathy(:,:) = 0       ! land  : set mbathy to 0 
    1001       ELSE WHERE                     ;   mbathy(:,:) = jpkm1   ! ocean : initialize mbathy to the max ocean level 
    1002       END WHERE 
    1003  
    1004       ! Compute mbathy for ocean points (i.e. the number of ocean levels) 
    1005       ! find the number of ocean levels such that the last level thickness 
    1006       ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where 
    1007       ! e3t_1d is the reference level thickness 
    1008       DO jk = jpkm1, 1, -1 
    1009          zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 
    1010          WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth )   mbathy(:,:) = jk-1 
    1011       END DO 
     1275      CALL wrk_alloc( jpi, jpj, zmisfdep, zmbathy ) 
     1276 
     1277 
    10121278      ! (ISF) compute misfdep 
    10131279      WHERE( risfdep(:,:) == 0._wp .AND. bathy(:,:) .NE. 0) ;   misfdep(:,:) = 1   ! open water : set misfdep to 1   
     
    10531319            misfdep(jpi,:) = misfdep(  2  ,:)  
    10541320         ENDIF 
    1055   
     1321 
    10561322         IF( nperio == 1 .OR. nperio  ==  4 .OR. nperio  ==  6 ) THEN 
    10571323            mbathy( 1 ,:) = mbathy(jpim1,:)             ! local domain is cyclic east-west 
    10581324            mbathy(jpi,:) = mbathy(  2  ,:) 
    10591325         ENDIF 
    1060   
     1326 
    10611327         ! split last cell if possible (only where water column is 2 cell or less) 
    10621328         DO jk = jpkm1, 1, -1 
     
    10761342            END WHERE 
    10771343         END DO 
    1078   
     1344 
    10791345  
    10801346 ! Case where bathy and risfdep compatible but not the level variable mbathy/misfdep because of partial cell condition 
     
    12521518  
    12531519 ! remove single point "bay" on isf coast line in the ice shelf draft' 
    1254          DO jk = 1, jpk 
     1520         DO jk = 2, jpk 
    12551521            WHERE (misfdep==0) misfdep=jpk 
    12561522            zmask=0 
     
    13571623               IF( zmbathy(ji,jj) .LT. misfdep(ji  ,jj+1) ) ibtestjp1 = 0 
    13581624               ibtest=MAX(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) 
    1359                IF( ibtest == 0 ) THEN 
     1625               IF( ibtest == 0 .AND. misfdep(ji,jj) .GE. 2) THEN 
    13601626                  mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp ; 
    13611627               END IF 
     
    14731739      ENDIF  
    14741740 
    1475       ! Scale factors and depth at T- and W-points 
    1476       DO jk = 1, jpk                        ! intitialization to the reference z-coordinate 
    1477          gdept_0(:,:,jk) = gdept_1d(jk) 
    1478          gdepw_0(:,:,jk) = gdepw_1d(jk) 
    1479          e3t_0  (:,:,jk) = e3t_1d  (jk) 
    1480          e3w_0  (:,:,jk) = e3w_1d  (jk) 
    1481       END DO 
    1482       !  
    1483       DO jj = 1, jpj 
    1484          DO ji = 1, jpi 
    1485             ik = mbathy(ji,jj) 
    1486             IF( ik > 0 ) THEN               ! ocean point only 
    1487                ! max ocean level case 
    1488                IF( ik == jpkm1 ) THEN 
    1489                   zdepwp = bathy(ji,jj) 
    1490                   ze3tp  = bathy(ji,jj) - gdepw_1d(ik) 
    1491                   ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) 
    1492                   e3t_0(ji,jj,ik  ) = ze3tp 
    1493                   e3t_0(ji,jj,ik+1) = ze3tp 
    1494                   e3w_0(ji,jj,ik  ) = ze3wp 
    1495                   e3w_0(ji,jj,ik+1) = ze3tp 
    1496                   gdepw_0(ji,jj,ik+1) = zdepwp 
    1497                   gdept_0(ji,jj,ik  ) = gdept_1d(ik-1) + ze3wp 
    1498                   gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp 
    1499                   ! 
    1500                ELSE                         ! standard case 
    1501                   IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN  ;   gdepw_0(ji,jj,ik+1) = bathy(ji,jj) 
    1502                   ELSE                                       ;   gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 
    1503                   ENDIF 
    1504 !gm Bug?  check the gdepw_1d 
    1505                   !       ... on ik 
    1506                   gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) )   & 
    1507                      &                             * ((gdept_1d(     ik  ) - gdepw_1d(ik) )   & 
    1508                      &                             / ( gdepw_1d(     ik+1) - gdepw_1d(ik) )) 
    1509                   e3t_0(ji,jj,ik) = e3t_1d (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) )   &  
    1510                      &                          / ( gdepw_1d(      ik+1) - gdepw_1d(ik) )  
    1511                   e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) )   & 
    1512                      &                     * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) 
    1513                   !       ... on ik+1 
    1514                   e3w_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
    1515                   e3t_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
    1516                   gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) 
    1517                ENDIF 
    1518             ENDIF 
    1519          END DO 
    1520       END DO 
    1521       ! 
    1522       it = 0 
    1523       DO jj = 1, jpj 
    1524          DO ji = 1, jpi 
    1525             ik = mbathy(ji,jj) 
    1526             IF( ik > 0 ) THEN               ! ocean point only 
    1527                e3tp (ji,jj) = e3t_0(ji,jj,ik) 
    1528                e3wp (ji,jj) = e3w_0(ji,jj,ik) 
    1529                ! test 
    1530                zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik  ) 
    1531                IF( zdiff <= 0._wp .AND. lwp ) THEN  
    1532                   it = it + 1 
    1533                   WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj 
    1534                   WRITE(numout,*) ' bathy = ', bathy(ji,jj) 
    1535                   WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 
    1536                   WRITE(numout,*) ' e3tp    = ', e3t_0  (ji,jj,ik), ' e3wp    = ', e3w_0  (ji,jj,ik  ) 
    1537                ENDIF 
    1538             ENDIF 
    1539          END DO 
    1540       END DO 
    1541       ! 
    1542       ! (ISF) Definition of e3t, u, v, w for ISF case 
    1543       DO jj = 1, jpj  
    1544          DO ji = 1, jpi  
    1545             ik = misfdep(ji,jj)  
    1546             IF( ik > 1 ) THEN               ! ice shelf point only  
    1547                IF( risfdep(ji,jj) < gdepw_1d(ik) )  risfdep(ji,jj)= gdepw_1d(ik)  
    1548                gdepw_0(ji,jj,ik) = risfdep(ji,jj)  
    1549 !gm Bug?  check the gdepw_0  
    1550                !       ... on ik  
    1551                gdept_0(ji,jj,ik) = gdepw_1d(ik+1) - ( gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) )   &  
    1552                   &                               * ( gdepw_1d(ik+1) - gdept_1d(ik)      )   &  
    1553                   &                               / ( gdepw_1d(ik+1) - gdepw_1d(ik)      )  
    1554                e3t_0  (ji,jj,ik  ) = gdepw_1d(ik+1) - gdepw_0(ji,jj,ik)  
    1555                e3w_0  (ji,jj,ik+1) = gdept_1d(ik+1) - gdept_0(ji,jj,ik) 
    1556  
    1557                IF( ik + 1 == mbathy(ji,jj) ) THEN               ! ice shelf point only (2 cell water column)  
    1558                   e3w_0  (ji,jj,ik+1) = gdept_0(ji,jj,ik+1) - gdept_0(ji,jj,ik)  
    1559                 ENDIF  
    1560                !       ... on ik / ik-1  
    1561                e3w_0  (ji,jj,ik  ) = 2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik))  
    1562                e3t_0  (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1) 
    1563 ! The next line isn't required and doesn't affect results - included for consistency with bathymetry code  
    1564                gdept_0(ji,jj,ik-1) = gdept_1d(ik-1) 
    1565             ENDIF  
    1566          END DO  
    1567       END DO  
    1568       !  
    1569       it = 0  
    1570       DO jj = 1, jpj  
    1571          DO ji = 1, jpi  
    1572             ik = misfdep(ji,jj)  
    1573             IF( ik > 1 ) THEN               ! ice shelf point only  
    1574                e3tp (ji,jj) = e3t_0(ji,jj,ik  )  
    1575                e3wp (ji,jj) = e3w_0(ji,jj,ik+1 )  
    1576                ! test  
    1577                zdiff= gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik  )  
    1578                IF( zdiff <= 0. .AND. lwp ) THEN   
    1579                   it = it + 1  
    1580                   WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj  
    1581                   WRITE(numout,*) ' risfdep = ', risfdep(ji,jj)  
    1582                   WRITE(numout,*) ' gdept = ', gdept_0(ji,jj,ik), ' gdepw = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff  
    1583                   WRITE(numout,*) ' e3tp  = ', e3tp(ji,jj), ' e3wp  = ', e3wp(ji,jj)  
    1584                ENDIF  
    1585             ENDIF  
    1586          END DO  
    1587       END DO  
    1588       ! END (ISF) 
    1589  
    1590       ! Scale factors and depth at U-, V-, UW and VW-points 
    1591       DO jk = 1, jpk                        ! initialisation to z-scale factors 
    1592          e3u_0 (:,:,jk) = e3t_1d(jk) 
    1593          e3v_0 (:,:,jk) = e3t_1d(jk) 
    1594          e3uw_0(:,:,jk) = e3w_1d(jk) 
    1595          e3vw_0(:,:,jk) = e3w_1d(jk) 
    1596       END DO 
    1597       DO jk = 1,jpk                         ! Computed as the minimum of neighbooring scale factors 
    1598          DO jj = 1, jpjm1 
    1599             DO ji = 1, fs_jpim1   ! vector opt. 
    1600                e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) 
    1601                e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) 
    1602                e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) 
    1603                e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) 
    1604             END DO 
    1605          END DO 
    1606       END DO 
    1607       ! (ISF) define e3uw 
    1608       DO jk = 2,jpk                           
    1609          DO jj = 1, jpjm1  
    1610             DO ji = 1, fs_jpim1   ! vector opt.  
    1611                e3uw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji+1,jj  ,jk) ) & 
    1612                  &   - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji+1,jj  ,jk-1) ) 
    1613                e3vw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji  ,jj+1,jk) ) & 
    1614                  &   - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji  ,jj+1,jk-1) ) 
    1615             END DO  
    1616          END DO  
    1617       END DO 
    1618       !End (ISF) 
    1619        
    1620       CALL lbc_lnk( e3u_0 , 'U', 1._wp )   ;   CALL lbc_lnk( e3uw_0, 'U', 1._wp )   ! lateral boundary conditions 
    1621       CALL lbc_lnk( e3v_0 , 'V', 1._wp )   ;   CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 
    1622       ! 
    1623       DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
    1624          WHERE( e3u_0 (:,:,jk) == 0._wp )   e3u_0 (:,:,jk) = e3t_1d(jk) 
    1625          WHERE( e3v_0 (:,:,jk) == 0._wp )   e3v_0 (:,:,jk) = e3t_1d(jk) 
    1626          WHERE( e3uw_0(:,:,jk) == 0._wp )   e3uw_0(:,:,jk) = e3w_1d(jk) 
    1627          WHERE( e3vw_0(:,:,jk) == 0._wp )   e3vw_0(:,:,jk) = e3w_1d(jk) 
    1628       END DO 
    1629        
    1630       ! Scale factor at F-point 
    1631       DO jk = 1, jpk                        ! initialisation to z-scale factors 
    1632          e3f_0(:,:,jk) = e3t_1d(jk) 
    1633       END DO 
    1634       DO jk = 1, jpk                        ! Computed as the minimum of neighbooring V-scale factors 
    1635          DO jj = 1, jpjm1 
    1636             DO ji = 1, fs_jpim1   ! vector opt. 
    1637                e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) 
    1638             END DO 
    1639          END DO 
    1640       END DO 
    1641       CALL lbc_lnk( e3f_0, 'F', 1._wp )       ! Lateral boundary conditions 
    1642       ! 
    1643       DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
    1644          WHERE( e3f_0(:,:,jk) == 0._wp )   e3f_0(:,:,jk) = e3t_1d(jk) 
    1645       END DO 
    1646 !!gm  bug ? :  must be a do loop with mj0,mj1 
    1647       !  
    1648       e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:)     ! we duplicate factor scales for jj = 1 and jj = 2 
    1649       e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:)  
    1650       e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:)  
    1651       e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:)  
    1652       e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:)  
    1653  
    1654       ! Control of the sign 
    1655       IF( MINVAL( e3t_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3t_0 <= 0' ) 
    1656       IF( MINVAL( e3w_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3w_0 <= 0' ) 
    1657       IF( MINVAL( gdept_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdept_0 <  0' ) 
    1658       IF( MINVAL( gdepw_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdepw_0 <  0' ) 
    1659       
    1660       ! Compute gdep3w_0 (vertical sum of e3w) 
    1661       WHERE (misfdep == 0) misfdep = 1 
    1662       DO jj = 1,jpj 
    1663          DO ji = 1,jpi 
    1664             gdep3w_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1) 
    1665             DO jk = 2, misfdep(ji,jj) 
    1666                gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
    1667             END DO 
    1668             IF (misfdep(ji,jj) .GE. 2) gdep3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5_wp * e3w_0(ji,jj,misfdep(ji,jj)) 
    1669             DO jk = misfdep(ji,jj) + 1, jpk 
    1670                gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
    1671             END DO 
    1672         END DO 
    1673       END DO 
    1674       !                                               ! ================= ! 
    1675       IF(lwp .AND. ll_print) THEN                     !   Control print   ! 
    1676          !                                            ! ================= ! 
    1677          DO jj = 1,jpj 
    1678             DO ji = 1, jpi 
    1679                ik = MAX( mbathy(ji,jj), 1 ) 
    1680                zprt(ji,jj,1) = e3t_0   (ji,jj,ik) 
    1681                zprt(ji,jj,2) = e3w_0   (ji,jj,ik) 
    1682                zprt(ji,jj,3) = e3u_0   (ji,jj,ik) 
    1683                zprt(ji,jj,4) = e3v_0   (ji,jj,ik) 
    1684                zprt(ji,jj,5) = e3f_0   (ji,jj,ik) 
    1685                zprt(ji,jj,6) = gdep3w_0(ji,jj,ik) 
    1686             END DO 
    1687          END DO 
    1688          WRITE(numout,*) 
    1689          WRITE(numout,*) 'domzgr e3t(mbathy)'      ;   CALL prihre(zprt(:,:,1),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1690          WRITE(numout,*) 
    1691          WRITE(numout,*) 'domzgr e3w(mbathy)'      ;   CALL prihre(zprt(:,:,2),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1692          WRITE(numout,*) 
    1693          WRITE(numout,*) 'domzgr e3u(mbathy)'      ;   CALL prihre(zprt(:,:,3),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1694          WRITE(numout,*) 
    1695          WRITE(numout,*) 'domzgr e3v(mbathy)'      ;   CALL prihre(zprt(:,:,4),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1696          WRITE(numout,*) 
    1697          WRITE(numout,*) 'domzgr e3f(mbathy)'      ;   CALL prihre(zprt(:,:,5),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1698          WRITE(numout,*) 
    1699          WRITE(numout,*) 'domzgr gdep3w(mbathy)'   ;   CALL prihre(zprt(:,:,6),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1700       ENDIF   
    1701       ! 
    1702       CALL wrk_dealloc( jpi, jpj, jpk, zprt ) 
    17031741      CALL wrk_dealloc( jpi, jpj, zmask, zbathy, zrisfdep ) 
    17041742      CALL wrk_dealloc( jpi, jpj, zmisfdep, zmbathy ) 
    1705       ! 
    1706       IF( nn_timing == 1 )  CALL timing_stop('zgr_zps') 
    1707       ! 
    1708    END SUBROUTINE zgr_zps 
     1743 
     1744      IF( nn_timing == 1 )  CALL timing_stop('zgr_isf') 
     1745       
     1746   END SUBROUTINE 
    17091747 
    17101748   SUBROUTINE zgr_sco 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/dtatsd.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    3939   !!---------------------------------------------------------------------- 
    4040   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    41    !! $Id: dtatem.F90 2392 2010-11-15 21:20:05Z gm $  
     41   !! $Id$  
    4242   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4343   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90

    r5038 r5620  
    6969      !! ** Purpose :   Initialization of the dynamics and tracer fields. 
    7070      !!---------------------------------------------------------------------- 
    71       ! - ML - needed for initialization of e3t_b 
    72       INTEGER  ::  ji,jj,jk     ! dummy loop indices 
    73       REAL(wp), POINTER, DIMENSION(:,:,:,:)  ::  zuvd    ! U & V data workspace 
     71      INTEGER ::   ji, jj, jk   ! dummy loop indices 
     72      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zuvd    ! U & V data workspace 
    7473      !!---------------------------------------------------------------------- 
    7574      ! 
     
    8483      IF( lk_c1d ) CALL dta_uvd_init          ! Initialization of U & V input data 
    8584 
    86       rhd  (:,:,:  ) = 0._wp 
    87       rhop (:,:,:  ) = 0._wp 
    88       rn2  (:,:,:  ) = 0._wp 
    89       tsa  (:,:,:,:) = 0._wp    
    90       rab_b(:,:,:,:) = 0._wp 
    91       rab_n(:,:,:,:) = 0._wp 
     85      rhd  (:,:,:  ) = 0._wp   ;   rhop (:,:,:  ) = 0._wp      ! set one for all to 0 at level jpk 
     86      rn2b (:,:,:  ) = 0._wp   ;   rn2  (:,:,:  ) = 0._wp      ! set one for all to 0 at levels 1 and jpk 
     87      tsa  (:,:,:,:) = 0._wp                                   ! set one for all to 0 at level jpk 
     88      rab_b(:,:,:,:) = 0._wp   ;   rab_n(:,:,:,:) = 0._wp      ! set one for all to 0 at level jpk 
    9289 
    9390      IF( ln_rstart ) THEN                    ! Restart from a file 
     
    113110         ELSEIF( cp_cfg == 'gyre' ) THEN          
    114111            CALL istate_gyre                     ! GYRE  configuration : start from pre-defined T-S fields 
    115         ELSEIF( cp_cfg == 'isomip' .OR. cp_cfg == 'isomip2') THEN 
    116             IF(lwp) WRITE(numout,*) 'Initialization of T+S for ISOMIP domain'  
    117             tsn(:,:,:,jp_tem)=-1.9*tmask(:,:,:)          ! ISOMIP configuration : start from constant T+S fields  
    118             tsn(:,:,:,jp_sal)=34.4*tmask(:,:,:) 
    119             tsb(:,:,:,:)=tsn(:,:,:,:)   
    120112         ELSE                                    ! Initial T-S, U-V fields read in files 
    121113            IF ( ln_tsd_init ) THEN              ! read 3D T and S data at nit000 
     
    137129         CALL eos( tsb, rhd, rhop, gdept_0(:,:,:) )        ! before potential and in situ densities 
    138130#if ! defined key_c1d 
    139          IF( ln_zps )    CALL zps_hde( nit000, jpts, tsb, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    140             &                                      rhd, gru , grv, aru, arv, gzu, gzv, ge3ru, ge3rv,  &             ! 
    141             &                                      gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     131         IF( ln_zps .AND. .NOT. ln_isfcav)                                 & 
     132            &            CALL zps_hde    ( nit000, jpts, tsb, gtsu, gtsv,  &    ! Partial steps: before horizontal gradient 
     133            &                                            rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     134         IF( ln_zps .AND.       ln_isfcav)                                 & 
     135            &            CALL zps_hde_isf( nit000, jpts, tsb, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     136            &                                            rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     137            &                                     gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
    142138#endif 
    143139         !    
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90

    r5038 r5620  
    4141   REAL(wp), PUBLIC ::   rt0      = 273.15_wp        !: freezing point of fresh water [Kelvin] 
    4242#if defined key_lim3 
    43    REAL(wp), PUBLIC ::   rt0_snow = 273.16_wp        !: melting point of snow         [Kelvin] 
    44    REAL(wp), PUBLIC ::   rt0_ice  = 273.16_wp        !: melting point of ice          [Kelvin] 
     43   REAL(wp), PUBLIC ::   rt0_snow = 273.15_wp        !: melting point of snow         [Kelvin] 
     44   REAL(wp), PUBLIC ::   rt0_ice  = 273.15_wp        !: melting point of ice          [Kelvin] 
    4545#else 
    4646   REAL(wp), PUBLIC ::   rt0_snow = 273.15_wp        !: melting point of snow         [Kelvin] 
     
    5151   REAL(wp), PUBLIC ::   rcp                         !: ocean specific heat           [J/Kelvin] 
    5252   REAL(wp), PUBLIC ::   r1_rcp                      !: = 1. / rcp                    [Kelvin/J] 
     53   REAL(wp), PUBLIC ::   rau0_rcp                    !: = rau0 * rcp  
    5354   REAL(wp), PUBLIC ::   r1_rau0_rcp                 !: = 1. / ( rau0 * rcp ) 
    5455 
     
    8283   REAL(wp), PUBLIC ::   xlic     =  300.33e+6_wp    !: volumetric latent heat fusion of ice                  [J/m3] 
    8384   REAL(wp), PUBLIC ::   xsn      =    2.8e+6_wp     !: volumetric latent heat of sublimation of snow         [J/m3] 
     85#endif 
     86#if defined key_lim3 
     87   REAL(wp), PUBLIC ::   r1_rhoic                    !: 1 / rhoic 
     88   REAL(wp), PUBLIC ::   r1_rhosn                    !: 1 / rhosn 
    8489#endif 
    8590   !!---------------------------------------------------------------------- 
     
    166171      lfus = xlsn / rhosn        ! latent heat of fusion of fresh ice 
    167172#endif 
    168  
     173#if defined key_lim3 
     174      r1_rhoic = 1._wp / rhoic 
     175      r1_rhosn = 1._wp / rhosn 
     176#endif 
    169177      IF(lwp) THEN 
    170178         WRITE(numout,*) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90

    r5038 r5620  
    1717   !!            3.3  ! 2010-09  (D.Storkey and E.O'Dea) bug fixes for BDY module 
    1818   !!             -   ! 2010-10  (R. Furner, G. Madec) runoff and cla added directly here 
     19   !!            3.6  ! 2014-11  (P. Mathiot)          isf            added directly here 
    1920   !!---------------------------------------------------------------------- 
    2021 
     
    9798      ! 
    9899      CALL wrk_alloc( jpi  , jpj+2, zwu               ) 
    99       CALL wrk_alloc( jpi+4, jpj  , zwv, kjstart = -1 ) 
     100      CALL wrk_alloc( jpi+4, jpj  , zwv, kistart = -1 ) 
    100101      ! 
    101102      IF( kt == nit000 ) THEN 
     
    236237      ! 
    237238      CALL wrk_dealloc( jpi  , jpj+2, zwu               ) 
    238       CALL wrk_dealloc( jpi+4, jpj  , zwv, kjstart = -1 ) 
     239      CALL wrk_dealloc( jpi+4, jpj  , zwv, kistart = -1 ) 
    239240      ! 
    240241      IF( nn_timing == 1 )  CALL timing_stop('div_cur') 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv.F90

    r5038 r5620  
    55   !!============================================================================== 
    66   !! History :  1.0  !  2006-11  (G. Madec)  Original code 
    7    !!            3.3  !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase 
     7   !!            3.3  !  2010-10  (C. Ethe, G. Madec)  reorganisation of initialisation phase 
     8   !!            3.6  !  2015-05  (N. Ducousso, G. Madec)  add Hollingsworth scheme as an option  
    89   !!---------------------------------------------------------------------- 
    910 
     
    1718   USE dynkeg          ! kinetic energy gradient          (dyn_keg      routine) 
    1819   USE dynzad          ! vertical advection               (dyn_zad      routine) 
     20   ! 
    1921   USE in_out_manager  ! I/O manager 
    2022   USE lib_mpp         ! MPP library 
     
    2527 
    2628   PUBLIC dyn_adv       ! routine called by step module 
    27    PUBLIC dyn_adv_init  ! routine called by opa module 
     29   PUBLIC dyn_adv_init  ! routine called by opa  module 
    2830  
     31   !                                    !* namdyn_adv namelist * 
    2932   LOGICAL, PUBLIC ::   ln_dynadv_vec   !: vector form flag 
     33   INTEGER, PUBLIC ::   nn_dynkeg       !: scheme of kinetic energy gradient: =0 C2 ; =1 Hollingsworth 
    3034   LOGICAL, PUBLIC ::   ln_dynadv_cen2  !: flux form - 2nd order centered scheme flag 
    3135   LOGICAL, PUBLIC ::   ln_dynadv_ubs   !: flux form - 3rd order UBS scheme flag 
     
    3842#  include "vectopt_loop_substitute.h90" 
    3943   !!---------------------------------------------------------------------- 
    40    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     44   !! NEMO/OPA 3.6 , NEMO Consortium (2015) 
    4145   !! $Id$ 
    4246   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     
    6367      SELECT CASE ( nadv )                  ! compute advection trend and add it to general trend 
    6468      CASE ( 0 )      
    65                       CALL dyn_keg     ( kt )    ! vector form : horizontal gradient of kinetic energy 
    66                       CALL dyn_zad     ( kt )    ! vector form : vertical advection 
     69                      CALL dyn_keg     ( kt, nn_dynkeg )    ! vector form : horizontal gradient of kinetic energy 
     70                      CALL dyn_zad     ( kt )               ! vector form : vertical advection 
    6771      CASE ( 1 )      
    68                       CALL dyn_keg     ( kt )    ! vector form : horizontal gradient of kinetic energy 
    69                       CALL dyn_zad_zts ( kt )    ! vector form : vertical advection with sub-timestepping 
     72                      CALL dyn_keg     ( kt, nn_dynkeg )    ! vector form : horizontal gradient of kinetic energy 
     73                      CALL dyn_zad_zts ( kt )               ! vector form : vertical advection with sub-timestepping 
    7074      CASE ( 2 )  
    71                       CALL dyn_adv_cen2( kt )    ! 2nd order centered scheme 
     75                      CALL dyn_adv_cen2( kt )               ! 2nd order centered scheme 
    7276      CASE ( 3 )    
    73                       CALL dyn_adv_ubs ( kt )    ! 3rd order UBS      scheme 
     77                      CALL dyn_adv_ubs ( kt )               ! 3rd order UBS      scheme 
    7478      ! 
    75       CASE (-1 )                                 ! esopa: test all possibility with control print 
    76                       CALL dyn_keg     ( kt ) 
     79      CASE (-1 )                                            ! esopa: test all possibility with control print 
     80                      CALL dyn_keg     ( kt, nn_dynkeg ) 
    7781                      CALL dyn_zad     ( kt ) 
    7882                      CALL dyn_adv_cen2( kt ) 
     
    9296      !!              momentum advection formulation & scheme and set nadv 
    9397      !!---------------------------------------------------------------------- 
    94       INTEGER ::   ioptio 
    95       INTEGER  ::   ios                 ! Local integer output status for namelist read 
    96       !! 
    97       NAMELIST/namdyn_adv/ ln_dynadv_vec, ln_dynadv_cen2 , ln_dynadv_ubs, ln_dynzad_zts 
     98      INTEGER ::   ioptio, ios   ! Local integer 
     99      ! 
     100      NAMELIST/namdyn_adv/ ln_dynadv_vec, nn_dynkeg, ln_dynadv_cen2 , ln_dynadv_ubs, ln_dynzad_zts 
    98101      !!---------------------------------------------------------------------- 
    99  
     102      ! 
    100103      REWIND( numnam_ref )              ! Namelist namdyn_adv in reference namelist : Momentum advection scheme 
    101104      READ  ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901) 
     
    112115         WRITE(numout,*) '~~~~~~~~~~~' 
    113116         WRITE(numout,*) '       Namelist namdyn_adv : chose a advection formulation & scheme for momentum' 
    114          WRITE(numout,*) '          Vector/flux form (T/F)             ln_dynadv_vec  = ', ln_dynadv_vec 
    115          WRITE(numout,*) '          2nd order centred advection scheme ln_dynadv_cen2 = ', ln_dynadv_cen2 
    116          WRITE(numout,*) '          3rd order UBS advection scheme     ln_dynadv_ubs  = ', ln_dynadv_ubs 
    117          WRITE(numout,*) '      Sub timestepping of vertical advection ln_dynzad_zts  = ', ln_dynzad_zts 
     117         WRITE(numout,*) '          Vector/flux form (T/F)                           ln_dynadv_vec  = ', ln_dynadv_vec 
     118         WRITE(numout,*) '          = 0 standard scheme  ; =1 Hollingsworth scheme   nn_dynkeg      = ', nn_dynkeg 
     119         WRITE(numout,*) '          2nd order centred advection scheme               ln_dynadv_cen2 = ', ln_dynadv_cen2 
     120         WRITE(numout,*) '          3rd order UBS advection scheme                   ln_dynadv_ubs  = ', ln_dynadv_ubs 
     121         WRITE(numout,*) '          Sub timestepping of vertical advection           ln_dynzad_zts  = ', ln_dynzad_zts 
    118122      ENDIF 
    119123 
     
    126130      IF( ioptio /= 1 )   CALL ctl_stop( 'Choose ONE advection scheme in namelist namdyn_adv' ) 
    127131      IF( ln_dynzad_zts .AND. .NOT. ln_dynadv_vec )   & 
    128           CALL ctl_stop( 'Sub timestepping of vertical advection requires vector form; set ln_dynadv_vec = .TRUE.' ) 
     132         CALL ctl_stop( 'Sub timestepping of vertical advection requires vector form; set ln_dynadv_vec = .TRUE.' ) 
     133      IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW )   &   
     134         CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) 
    129135 
    130136      !                               ! Set nadv 
     
    137143      IF(lwp) THEN                    ! Print the choice 
    138144         WRITE(numout,*) 
    139          IF( nadv ==  0 )   WRITE(numout,*) '         vector form : keg + zad + vor is used' 
     145         IF( nadv ==  0 )   WRITE(numout,*) '         vector form : keg + zad + vor is used'  
    140146         IF( nadv ==  1 )   WRITE(numout,*) '         vector form : keg + zad_zts + vor is used' 
     147         IF( nadv ==  0 .OR. nadv ==  1 ) THEN 
     148            IF( nn_dynkeg == nkeg_C2  )   WRITE(numout,*) 'with Centered standard keg scheme' 
     149            IF( nn_dynkeg == nkeg_HW  )   WRITE(numout,*) 'with Hollingsworth keg scheme' 
     150         ENDIF 
    141151         IF( nadv ==  2 )   WRITE(numout,*) '         flux form   : 2nd order scheme is used' 
    142152         IF( nadv ==  3 )   WRITE(numout,*) '         flux form   : UBS       scheme is used' 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_ubs.F90

    r5038 r5620  
    116116         DO jj = 2, jpjm1                          ! laplacian 
    117117            DO ji = fs_2, fs_jpim1   ! vector opt. 
    118                zlu_uu(ji,jj,jk,1) = ( ub (ji+1,jj,jk)-2.*ub (ji,jj,jk)+ub (ji-1,jj,jk) ) * umask(ji,jj,jk) 
    119                zlv_vv(ji,jj,jk,1) = ( vb (ji,jj+1,jk)-2.*vb (ji,jj,jk)+vb (ji,jj-1,jk) ) * vmask(ji,jj,jk)  
    120                zlu_uv(ji,jj,jk,1) = ( ub (ji,jj+1,jk)-2.*ub (ji,jj,jk)+ub (ji,jj-1,jk) ) * umask(ji,jj,jk) 
    121                zlv_vu(ji,jj,jk,1) = ( vb (ji+1,jj,jk)-2.*vb (ji,jj,jk)+vb (ji-1,jj,jk) ) * vmask(ji,jj,jk) 
    122                ! 
    123                zlu_uu(ji,jj,jk,2) = ( zfu(ji+1,jj,jk)-2.*zfu(ji,jj,jk)+zfu(ji-1,jj,jk) ) * umask(ji,jj,jk) 
    124                zlv_vv(ji,jj,jk,2) = ( zfv(ji,jj+1,jk)-2.*zfv(ji,jj,jk)+zfv(ji,jj-1,jk) ) * vmask(ji,jj,jk) 
    125                zlu_uv(ji,jj,jk,2) = ( zfu(ji,jj+1,jk)-2.*zfu(ji,jj,jk)+zfu(ji,jj-1,jk) ) * umask(ji,jj,jk) 
    126                zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj,jk)-2.*zfv(ji,jj,jk)+zfv(ji-1,jj,jk) ) * vmask(ji,jj,jk) 
    127             END DO 
    128          END DO 
    129       END DO 
    130 !!gm BUG !!!  just below this should be +1 in all the communications 
    131 !      CALL lbc_lnk( zlu_uu(:,:,:,1), 'U', -1.)   ;   CALL lbc_lnk( zlu_uv(:,:,:,1), 'U', -1.) 
    132 !      CALL lbc_lnk( zlu_uu(:,:,:,2), 'U', -1.)   ;   CALL lbc_lnk( zlu_uv(:,:,:,2), 'U', -1.) 
    133 !      CALL lbc_lnk( zlv_vv(:,:,:,1), 'V', -1.)   ;   CALL lbc_lnk( zlv_vu(:,:,:,1), 'V', -1.) 
    134 !      CALL lbc_lnk( zlv_vv(:,:,:,2), 'V', -1.)   ;   CALL lbc_lnk( zlv_vu(:,:,:,2), 'V', -1.) 
    135 ! 
    136 !!gm corrected: 
     118               ! 
     119               zlu_uu(ji,jj,jk,1) = ( ub (ji+1,jj  ,jk) - 2.*ub (ji,jj,jk) + ub (ji-1,jj  ,jk) ) * umask(ji,jj,jk) 
     120               zlv_vv(ji,jj,jk,1) = ( vb (ji  ,jj+1,jk) - 2.*vb (ji,jj,jk) + vb (ji  ,jj-1,jk) ) * vmask(ji,jj,jk) 
     121               zlu_uv(ji,jj,jk,1) = ( ub (ji  ,jj+1,jk) - ub (ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   & 
     122                  &               - ( ub (ji  ,jj  ,jk) - ub (ji  ,jj-1,jk) ) * fmask(ji  ,jj-1,jk) 
     123               zlv_vu(ji,jj,jk,1) = ( vb (ji+1,jj  ,jk) - vb (ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   & 
     124                  &               - ( vb (ji  ,jj  ,jk) - vb (ji-1,jj  ,jk) ) * fmask(ji-1,jj  ,jk) 
     125               ! 
     126               zlu_uu(ji,jj,jk,2) = ( zfu(ji+1,jj  ,jk) - 2.*zfu(ji,jj,jk) + zfu(ji-1,jj  ,jk) ) * umask(ji,jj,jk) 
     127               zlv_vv(ji,jj,jk,2) = ( zfv(ji  ,jj+1,jk) - 2.*zfv(ji,jj,jk) + zfv(ji  ,jj-1,jk) ) * vmask(ji,jj,jk) 
     128               zlu_uv(ji,jj,jk,2) = ( zfu(ji  ,jj+1,jk) - zfu(ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   & 
     129                  &               - ( zfu(ji  ,jj  ,jk) - zfu(ji  ,jj-1,jk) ) * fmask(ji  ,jj-1,jk) 
     130               zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj  ,jk) - zfv(ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   & 
     131                  &               - ( zfv(ji  ,jj  ,jk) - zfv(ji-1,jj  ,jk) ) * fmask(ji-1,jj  ,jk) 
     132            END DO 
     133         END DO 
     134      END DO 
    137135      CALL lbc_lnk( zlu_uu(:,:,:,1), 'U', 1. )   ;   CALL lbc_lnk( zlu_uv(:,:,:,1), 'U', 1. ) 
    138136      CALL lbc_lnk( zlu_uu(:,:,:,2), 'U', 1. )   ;   CALL lbc_lnk( zlu_uv(:,:,:,2), 'U', 1. ) 
    139137      CALL lbc_lnk( zlv_vv(:,:,:,1), 'V', 1. )   ;   CALL lbc_lnk( zlv_vu(:,:,:,1), 'V', 1. ) 
    140138      CALL lbc_lnk( zlv_vv(:,:,:,2), 'V', 1. )   ;   CALL lbc_lnk( zlv_vu(:,:,:,2), 'V', 1. )  
    141 !!gm end 
    142139       
    143140      !                                      ! ====================== ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynbfr.F90

    r5038 r5620  
    8080              ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + MAX(  bfrua(ji,jj) / fse3u(ji,jj,ikbu) , zm1_2dt  ) * ub(ji,jj,ikbu) 
    8181              va(ji,jj,ikbv) = va(ji,jj,ikbv) + MAX(  bfrva(ji,jj) / fse3v(ji,jj,ikbv) , zm1_2dt  ) * vb(ji,jj,ikbv) 
    82                
    83               ! (ISF) stability criteria for top friction 
    84               ikbu = miku(ji,jj)          ! first wet ocean u- & v-levels 
    85               ikbv = mikv(ji,jj) 
    86               ! 
    87               ! Apply stability criteria on absolute value  : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 
    88               ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + MAX(  tfrua(ji,jj) / fse3u(ji,jj,ikbu) , zm1_2dt  ) * ub(ji,jj,ikbu) & 
    89                  &             * (1.-umask(ji,jj,1)) 
    90               va(ji,jj,ikbv) = va(ji,jj,ikbv) + MAX(  tfrva(ji,jj) / fse3v(ji,jj,ikbv) , zm1_2dt  ) * vb(ji,jj,ikbv) & 
    91                  &             * (1.-vmask(ji,jj,1)) 
    92               ! (ISF) 
    93                
    9482           END DO 
    9583        END DO 
     84         
     85        IF ( ln_isfcav ) THEN 
     86           DO jj = 2, jpjm1 
     87              DO ji = 2, jpim1 
     88                 ! (ISF) stability criteria for top friction 
     89                 ikbu = miku(ji,jj)          ! first wet ocean u- & v-levels 
     90                 ikbv = mikv(ji,jj) 
     91                 ! 
     92                 ! Apply stability criteria on absolute value  : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 
     93                 ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + MAX(  tfrua(ji,jj) / fse3u(ji,jj,ikbu) , zm1_2dt  ) * ub(ji,jj,ikbu) & 
     94                    &             * (1.-umask(ji,jj,1)) 
     95                 va(ji,jj,ikbv) = va(ji,jj,ikbv) + MAX(  tfrva(ji,jj) / fse3v(ji,jj,ikbv) , zm1_2dt  ) * vb(ji,jj,ikbv) & 
     96                    &             * (1.-vmask(ji,jj,1)) 
     97                 ! (ISF) 
     98              END DO 
     99           END DO 
     100        END IF 
    96101 
    97102        ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90

    r5038 r5620  
    1616   !!            3.4  !  2011-11  (H. Liu) hpg_prj: Original code for s-coordinates 
    1717   !!                 !           (A. Coward) suppression of hel, wdj and rot options 
     18   !!            3.6  !  2014-11  (P. Mathiot) hpg_isf: original code for ice shelf cavity 
    1819   !!---------------------------------------------------------------------- 
    1920 
     
    2526   !!       hpg_zps  : z-coordinate plus partial steps (interpolation) 
    2627   !!       hpg_sco  : s-coordinate (standard jacobian formulation) 
     28   !!       hpg_isf  : s-coordinate (sco formulation) adapted to ice shelf 
    2729   !!       hpg_djc  : s-coordinate (Density Jacobian with Cubic polynomial) 
    2830   !!       hpg_prj  : s-coordinate (Pressure Jacobian with Cubic polynomial) 
     
    5557   LOGICAL , PUBLIC ::   ln_hpg_djc      !: s-coordinate (Density Jacobian with Cubic polynomial) 
    5658   LOGICAL , PUBLIC ::   ln_hpg_prj      !: s-coordinate (Pressure Jacobian scheme) 
     59   LOGICAL , PUBLIC ::   ln_hpg_isf      !: s-coordinate similar to sco modify for isf 
    5760   LOGICAL , PUBLIC ::   ln_dynhpg_imp   !: semi-implicite hpg flag 
    5861 
     
    97100      CASE (  3 )   ;   CALL hpg_djc    ( kt )      ! s-coordinate (Density Jacobian with Cubic polynomial) 
    98101      CASE (  4 )   ;   CALL hpg_prj    ( kt )      ! s-coordinate (Pressure Jacobian scheme) 
     102      CASE (  5 )   ;   CALL hpg_isf    ( kt )      ! s-coordinate similar to sco modify for ice shelf 
    99103      END SELECT 
    100104      ! 
     
    128132      !! 
    129133      NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco,     & 
    130          &                 ln_hpg_djc, ln_hpg_prj, ln_dynhpg_imp 
     134         &                 ln_hpg_djc, ln_hpg_prj, ln_hpg_isf, ln_dynhpg_imp 
    131135      !!---------------------------------------------------------------------- 
    132136      ! 
     
    148152         WRITE(numout,*) '      z-coord. - partial steps (interpolation)          ln_hpg_zps    = ', ln_hpg_zps 
    149153         WRITE(numout,*) '      s-coord. (standard jacobian formulation)          ln_hpg_sco    = ', ln_hpg_sco 
     154         WRITE(numout,*) '      s-coord. (standard jacobian formulation) for isf  ln_hpg_isf    = ', ln_hpg_isf 
    150155         WRITE(numout,*) '      s-coord. (Density Jacobian: Cubic polynomial)     ln_hpg_djc    = ', ln_hpg_djc 
    151156         WRITE(numout,*) '      s-coord. (Pressure Jacobian: Cubic polynomial)    ln_hpg_prj    = ', ln_hpg_prj 
     
    158163                           & either  ln_hpg_sco or  ln_hpg_prj instead') 
    159164      ! 
    160       IF( lk_vvl .AND. .NOT. (ln_hpg_sco.OR.ln_hpg_prj) )   & 
     165      IF( lk_vvl .AND. .NOT. (ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) )   & 
    161166         &   CALL ctl_stop('dyn_hpg_init : variable volume key_vvl requires:& 
    162167                           & the standard jacobian formulation hpg_sco or & 
    163168                           & the pressure jacobian formulation hpg_prj') 
     169 
     170      IF(       ln_hpg_isf .AND. .NOT. ln_isfcav )   & 
     171         &   CALL ctl_stop( ' hpg_isf not available if ln_isfcav = false ' ) 
     172      IF( .NOT. ln_hpg_isf .AND.       ln_isfcav )   & 
     173         &   CALL ctl_stop( 'Only hpg_isf has been corrected to work with ice shelf cavity.' ) 
    164174      ! 
    165175      !                               ! Set nhpg from ln_hpg_... flags 
     
    169179      IF( ln_hpg_djc )   nhpg = 3 
    170180      IF( ln_hpg_prj )   nhpg = 4 
     181      IF( ln_hpg_isf )   nhpg = 5 
    171182      ! 
    172183      !                               ! Consistency check 
     
    177188      IF( ln_hpg_djc )   ioptio = ioptio + 1 
    178189      IF( ln_hpg_prj )   ioptio = ioptio + 1 
     190      IF( ln_hpg_isf )   ioptio = ioptio + 1 
    179191      IF( ioptio /= 1 )   CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) 
    180       IF( (ln_hpg_zco .OR. ln_hpg_zps .OR. ln_hpg_djc .OR. ln_hpg_prj ) .AND. nn_isf .NE. 0 )   & 
    181           &  CALL ctl_stop( 'Only hpg_sco has been corrected to work with ice shelf cavity.' ) 
     192      !  
     193      ! initialisation of ice load 
     194      riceload(:,:)=0.0 
    182195      ! 
    183196   END SUBROUTINE dyn_hpg_init 
     
    345358   END SUBROUTINE hpg_zps 
    346359 
    347  
    348360   SUBROUTINE hpg_sco( kt ) 
    349361      !!--------------------------------------------------------------------- 
     
    366378      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    367379      !! 
     380      INTEGER  ::   ji, jj, jk                 ! dummy loop indices 
     381      REAL(wp) ::   zcoef0, zuap, zvap, znad   ! temporary scalars 
     382      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zhpi, zhpj 
     383      !!---------------------------------------------------------------------- 
     384      ! 
     385      CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 
     386      ! 
     387      IF( kt == nit000 ) THEN 
     388         IF(lwp) WRITE(numout,*) 
     389         IF(lwp) WRITE(numout,*) 'dyn:hpg_sco : hydrostatic pressure gradient trend' 
     390         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   s-coordinate case, OPA original scheme used' 
     391      ENDIF 
     392 
     393      ! Local constant initialization 
     394      zcoef0 = - grav * 0.5_wp 
     395      ! To use density and not density anomaly 
     396      IF ( lk_vvl ) THEN   ;     znad = 1._wp          ! Variable volume 
     397      ELSE                 ;     znad = 0._wp         ! Fixed volume 
     398      ENDIF 
     399 
     400      ! Surface value 
     401      DO jj = 2, jpjm1 
     402         DO ji = fs_2, fs_jpim1   ! vector opt. 
     403            ! hydrostatic pressure gradient along s-surfaces 
     404            zhpi(ji,jj,1) = zcoef0 / e1u(ji,jj) * ( fse3w(ji+1,jj  ,1) * ( znad + rhd(ji+1,jj  ,1) )   & 
     405               &                                  - fse3w(ji  ,jj  ,1) * ( znad + rhd(ji  ,jj  ,1) ) ) 
     406            zhpj(ji,jj,1) = zcoef0 / e2v(ji,jj) * ( fse3w(ji  ,jj+1,1) * ( znad + rhd(ji  ,jj+1,1) )   & 
     407               &                                  - fse3w(ji  ,jj  ,1) * ( znad + rhd(ji  ,jj  ,1) ) ) 
     408            ! s-coordinate pressure gradient correction 
     409            zuap = -zcoef0 * ( rhd   (ji+1,jj,1) + rhd   (ji,jj,1) + 2._wp * znad )   & 
     410               &           * ( fsde3w(ji+1,jj,1) - fsde3w(ji,jj,1) ) / e1u(ji,jj) 
     411            zvap = -zcoef0 * ( rhd   (ji,jj+1,1) + rhd   (ji,jj,1) + 2._wp * znad )   & 
     412               &           * ( fsde3w(ji,jj+1,1) - fsde3w(ji,jj,1) ) / e2v(ji,jj) 
     413            ! add to the general momentum trend 
     414            ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + zuap 
     415            va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + zvap 
     416         END DO 
     417      END DO 
     418 
     419      ! interior value (2=<jk=<jpkm1) 
     420      DO jk = 2, jpkm1 
     421         DO jj = 2, jpjm1 
     422            DO ji = fs_2, fs_jpim1   ! vector opt. 
     423               ! hydrostatic pressure gradient along s-surfaces 
     424               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)   & 
     425                  &           * (  fse3w(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad )   & 
     426                  &              - fse3w(ji  ,jj,jk) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad )  ) 
     427               zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj)   & 
     428                  &           * (  fse3w(ji,jj+1,jk) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad )   & 
     429                  &              - fse3w(ji,jj  ,jk) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad )  ) 
     430               ! s-coordinate pressure gradient correction 
     431               zuap = -zcoef0 * ( rhd   (ji+1,jj  ,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
     432                  &           * ( fsde3w(ji+1,jj  ,jk) - fsde3w(ji,jj,jk) ) / e1u(ji,jj) 
     433               zvap = -zcoef0 * ( rhd   (ji  ,jj+1,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
     434                  &           * ( fsde3w(ji  ,jj+1,jk) - fsde3w(ji,jj,jk) ) / e2v(ji,jj) 
     435               ! add to the general momentum trend 
     436               ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + zuap 
     437               va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) + zvap 
     438            END DO 
     439         END DO 
     440      END DO 
     441      ! 
     442      CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj ) 
     443      ! 
     444   END SUBROUTINE hpg_sco 
     445 
     446   SUBROUTINE hpg_isf( kt ) 
     447      !!--------------------------------------------------------------------- 
     448      !!                  ***  ROUTINE hpg_sco  *** 
     449      !! 
     450      !! ** Method  :   s-coordinate case. Jacobian scheme. 
     451      !!      The now hydrostatic pressure gradient at a given level, jk, 
     452      !!      is computed by taking the vertical integral of the in-situ 
     453      !!      density gradient along the model level from the suface to that 
     454      !!      level. s-coordinates (ln_sco): a corrective term is added 
     455      !!      to the horizontal pressure gradient : 
     456      !!         zhpi = grav .....  + 1/e1u mi(rhd) di[ grav dep3w ] 
     457      !!         zhpj = grav .....  + 1/e2v mj(rhd) dj[ grav dep3w ] 
     458      !!      add it to the general momentum trend (ua,va). 
     459      !!         ua = ua - 1/e1u * zhpi 
     460      !!         va = va - 1/e2v * zhpj 
     461      !!      iceload is added and partial cell case are added to the top and bottom 
     462      !!       
     463      !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 
     464      !!---------------------------------------------------------------------- 
     465      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
     466      !! 
    368467      INTEGER  ::   ji, jj, jk, iku, ikv, ikt, iktp1i, iktp1j                 ! dummy loop indices 
    369468      REAL(wp) ::   zcoef0, zuap, zvap, znad, ze3wu, ze3wv, zuapint, zvapint, zhpjint, zhpiint, zdzwt, zdzwtjp1, zdzwtip1             ! temporary scalars 
     
    379478     IF( kt == nit000 ) THEN 
    380479         IF(lwp) WRITE(numout,*) 
    381          IF(lwp) WRITE(numout,*) 'dyn:hpg_sco : hydrostatic pressure gradient trend' 
     480         IF(lwp) WRITE(numout,*) 'dyn:hpg_isf : hydrostatic pressure gradient trend for ice shelf' 
    382481         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   s-coordinate case, OPA original scheme used' 
    383482      ENDIF 
     
    565664!================================================================================== 
    566665 
    567 # if defined key_vectopt_loop 
    568          jj = 1 
    569          DO ji = jpi+2, jpij-jpi-1   ! vector opt. (forced unrolling) 
    570 # else 
    571666      DO jj = 2, jpjm1 
    572667         DO ji = 2, jpim1 
    573 # endif 
    574668            iku = mbku(ji,jj) 
    575669            ikv = mbkv(ji,jj) 
     
    598692               va(ji,jj,ikv)   =  va(ji,jj,ikv) + zhpj(ji,jj,ikv) + zvap 
    599693            END IF 
    600 # if ! defined key_vectopt_loop 
    601          END DO 
    602 # endif 
     694         END DO 
    603695      END DO 
    604696      
     
    610702      CALL wrk_dealloc( jpi,jpj, ze3w, zp, zrhdtop_isf, zrhdtop_oce, ziceload, zdept, zpshpi, zpshpj) 
    611703      ! 
    612    END SUBROUTINE hpg_sco 
     704   END SUBROUTINE hpg_isf 
    613705 
    614706 
     
    864956      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zdept, zrhh 
    865957      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp 
     958      REAL(wp), POINTER, DIMENSION(:,:)   ::   zsshu_n, zsshv_n 
    866959      !!---------------------------------------------------------------------- 
    867960      ! 
    868961      CALL wrk_alloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 
    869962      CALL wrk_alloc( jpi,jpj,jpk, zdept, zrhh ) 
     963      CALL wrk_alloc( jpi,jpj, zsshu_n, zsshv_n ) 
    870964      ! 
    871965      IF( kt == nit000 ) THEN 
     
    9481042 
    9491043      ! Z coordinate of U(ji,jj,1:jpkm1) and V(ji,jj,1:jpkm1) 
     1044 
     1045      ! Prepare zsshu_n and zsshv_n 
    9501046      DO jj = 2, jpjm1 
    9511047        DO ji = 2, jpim1 
    952           zu(ji,jj,1) = - ( fse3u(ji,jj,1) - sshn(ji,jj) * znad)    ! probable bug: changed from sshu_n for ztilde compilation 
    953           zv(ji,jj,1) = - ( fse3v(ji,jj,1) - sshn(ji,jj) * znad)    ! probable bug: changed from sshv_n for ztilde compilation 
     1048          zsshu_n(ji,jj) = (e12u(ji,jj) * sshn(ji,jj) + e12u(ji+1, jj) * sshn(ji+1,jj)) * & 
     1049                         & r1_e12u(ji,jj) * umask(ji,jj,1) * 0.5_wp  
     1050          zsshv_n(ji,jj) = (e12v(ji,jj) * sshn(ji,jj) + e12v(ji+1, jj) * sshn(ji,jj+1)) * & 
     1051                         & r1_e12v(ji,jj) * vmask(ji,jj,1) * 0.5_wp  
     1052        END DO 
     1053      END DO 
     1054 
     1055      DO jj = 2, jpjm1 
     1056        DO ji = 2, jpim1 
     1057          zu(ji,jj,1) = - ( fse3u(ji,jj,1) - zsshu_n(ji,jj) * znad)  
     1058          zv(ji,jj,1) = - ( fse3v(ji,jj,1) - zsshv_n(ji,jj) * znad) 
    9541059        END DO 
    9551060      END DO 
     
    11131218      CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 
    11141219      CALL wrk_dealloc( jpi,jpj,jpk, zdept, zrhh ) 
     1220      CALL wrk_dealloc( jpi,jpj, zsshu_n, zsshv_n ) 
    11151221      ! 
    11161222   END SUBROUTINE hpg_prj 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynkeg.F90

    r5038 r5620  
    44   !! Ocean dynamics:  kinetic energy gradient trend 
    55   !!====================================================================== 
    6    !! History :  1.0  !  87-09  (P. Andrich, m.-a. Foujols)  Original code 
    7    !!            7.0  !  97-05  (G. Madec)  Split dynber into dynkeg and dynhpg 
    8    !!            9.0  !  02-07  (G. Madec)  F90: Free form and module 
     6   !! History :  1.0  !  1987-09  (P. Andrich, M.-A. Foujols)  Original code 
     7   !!            7.0  !  1997-05  (G. Madec)  Split dynber into dynkeg and dynhpg 
     8   !!  NEMO      1.0  !  2002-07  (G. Madec)  F90: Free form and module 
     9   !!            3.6  !  2015-05  (N. Ducousso, G. Madec)  add Hollingsworth scheme as an option  
    910   !!---------------------------------------------------------------------- 
    1011    
     
    1819   ! 
    1920   USE in_out_manager  ! I/O manager 
     21   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2022   USE lib_mpp         ! MPP library 
    2123   USE prtctl          ! Print control 
     
    2830   PUBLIC   dyn_keg    ! routine called by step module 
    2931    
     32   INTEGER, PARAMETER, PUBLIC  ::   nkeg_C2  = 0   !: 2nd order centered scheme (standard scheme) 
     33   INTEGER, PARAMETER, PUBLIC  ::   nkeg_HW  = 1   !: Hollingsworth et al., QJRMS, 1983 
     34   ! 
     35   REAL(wp) ::   r1_48 = 1._wp / 48._wp   !: =1/(4*2*6) 
     36    
    3037   !! * Substitutions 
    3138#  include "vectopt_loop_substitute.h90" 
    3239   !!---------------------------------------------------------------------- 
    33    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     40   !! NEMO/OPA 3.6 , NEMO Consortium (2015) 
    3441   !! $Id$  
    3542   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     
    3744CONTAINS 
    3845 
    39    SUBROUTINE dyn_keg( kt ) 
     46   SUBROUTINE dyn_keg( kt, kscheme ) 
    4047      !!---------------------------------------------------------------------- 
    4148      !!                  ***  ROUTINE dyn_keg  *** 
     
    4552      !!      general momentum trend. 
    4653      !! 
    47       !! ** Method  :   Compute the now horizontal kinetic energy  
     54      !! ** Method  : * kscheme = nkeg_C2 : 2nd order centered scheme that  
     55      !!      conserve kinetic energy. Compute the now horizontal kinetic energy  
    4856      !!         zhke = 1/2 [ mi-1( un^2 ) + mj-1( vn^2 ) ] 
     57      !!              * kscheme = nkeg_HW : Hollingsworth correction following 
     58      !!      Arakawa (2001). The now horizontal kinetic energy is given by: 
     59      !!         zhke = 1/6 [ mi-1(  2 * un^2 + ((un(j+1)+un(j-1))/2)^2  ) 
     60      !!                    + mj-1(  2 * vn^2 + ((vn(i+1)+vn(i-1))/2)^2  ) ] 
     61      !!       
    4962      !!      Take its horizontal gradient and add it to the general momentum 
    5063      !!      trend (ua,va). 
     
    5467      !! ** Action : - Update the (ua, va) with the hor. ke gradient trend 
    5568      !!             - send this trends to trd_dyn (l_trddyn=T) for post-processing 
     69      !! 
     70      !! ** References : Arakawa, A., International Geophysics 2001. 
     71      !!                 Hollingsworth et al., Quart. J. Roy. Meteor. Soc., 1983. 
    5672      !!---------------------------------------------------------------------- 
    57       INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
     73      INTEGER, INTENT( in ) ::   kt        ! ocean time-step index 
     74      INTEGER, INTENT( in ) ::   kscheme   ! =0/1   type of KEG scheme  
    5875      ! 
    5976      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     
    6380      !!---------------------------------------------------------------------- 
    6481      ! 
    65       IF( nn_timing == 1 )  CALL timing_start('dyn_keg') 
     82      IF( nn_timing == 1 )   CALL timing_start('dyn_keg') 
    6683      ! 
    67       CALL wrk_alloc( jpi, jpj, jpk, zhke ) 
     84      CALL wrk_alloc( jpi,jpj,jpk,  zhke ) 
    6885      ! 
    6986      IF( kt == nit000 ) THEN 
    7087         IF(lwp) WRITE(numout,*) 
    71          IF(lwp) WRITE(numout,*) 'dyn_keg : kinetic energy gradient trend' 
     88         IF(lwp) WRITE(numout,*) 'dyn_keg : kinetic energy gradient trend, scheme number=', kscheme 
    7289         IF(lwp) WRITE(numout,*) '~~~~~~~' 
    7390      ENDIF 
    7491 
    7592      IF( l_trddyn ) THEN           ! Save ua and va trends 
    76          CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv ) 
     93         CALL wrk_alloc( jpi,jpj,jpk,   ztrdu, ztrdv ) 
    7794         ztrdu(:,:,:) = ua(:,:,:)  
    7895         ztrdv(:,:,:) = va(:,:,:)  
    7996      ENDIF 
    8097       
    81       !                                                ! =============== 
    82       DO jk = 1, jpkm1                                 ! Horizontal slab 
    83          !                                             ! =============== 
    84          DO jj = 2, jpj         ! Horizontal kinetic energy at T-point 
    85             DO ji = fs_2, jpi   ! vector opt. 
    86                zu = 0.25 * (  un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)   & 
    87                   &         + un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk)  ) 
    88                zv = 0.25 * (  vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)   & 
    89                   &         + vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk)  ) 
    90                zhke(ji,jj,jk) = zv + zu 
    91 !!gm simplier coding  ==>>   ~ faster 
    92 !    don't forget to suppress local zu zv scalars 
    93 !               zhke(ji,jj,jk) = 0.25 * (   un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)   & 
    94 !                  &                      + un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk)   & 
    95 !                  &                      + vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)   & 
    96 !                  &                      + vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk)   ) 
    97 !!gm end <<== 
    98             END DO   
    99          END DO   
    100          DO jj = 2, jpjm1       ! add the gradient of kinetic energy to the general momentum trends 
     98      zhke(:,:,jpk) = 0._wp 
     99       
     100      SELECT CASE ( kscheme )             !== Horizontal kinetic energy at T-point  ==! 
     101      ! 
     102      CASE ( nkeg_C2 )                          !--  Standard scheme  --! 
     103         DO jk = 1, jpkm1 
     104            DO jj = 2, jpj 
     105               DO ji = fs_2, jpi   ! vector opt. 
     106                  zu =    un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)   & 
     107                     &  + un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk) 
     108                  zv =    vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)   & 
     109                     &  + vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk) 
     110                  zhke(ji,jj,jk) = 0.25_wp * ( zv + zu ) 
     111               END DO   
     112            END DO 
     113         END DO 
     114         ! 
     115      CASE ( nkeg_HW )                          !--  Hollingsworth scheme  --! 
     116         DO jk = 1, jpkm1 
     117            DO jj = 2, jpjm1        
     118               DO ji = fs_2, jpim1   ! vector opt. 
     119                  zu = 8._wp * ( un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)    & 
     120                     &         + un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk) )  & 
     121                     &   +     ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) ) * ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) )   & 
     122                     &   +     ( un(ji  ,jj-1,jk) + un(ji  ,jj+1,jk) ) * ( un(ji  ,jj-1,jk) + un(ji  ,jj+1,jk) ) 
     123                     ! 
     124                  zv = 8._wp * ( vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)    & 
     125                     &         + vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk) )  & 
     126                     &  +      ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) ) * ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) )   & 
     127                     &  +      ( vn(ji-1,jj  ,jk) + vn(ji+1,jj  ,jk) ) * ( vn(ji-1,jj  ,jk) + vn(ji+1,jj  ,jk) ) 
     128                  zhke(ji,jj,jk) = r1_48 * ( zv + zu ) 
     129               END DO   
     130            END DO 
     131         END DO 
     132         CALL lbc_lnk( zhke, 'T', 1. ) 
     133         ! 
     134      END SELECT 
     135      ! 
     136      DO jk = 1, jpkm1                    !==  grad( KE ) added to the general momentum trends  ==! 
     137         DO jj = 2, jpjm1 
    101138            DO ji = fs_2, fs_jpim1   ! vector opt. 
    102139               ua(ji,jj,jk) = ua(ji,jj,jk) - ( zhke(ji+1,jj  ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) 
     
    104141            END DO  
    105142         END DO 
    106 !!gm idea to be tested  ==>>   is it faster on scalar computers ? 
    107 !         DO jj = 2, jpjm1       ! add the gradient of kinetic energy to the general momentum trends 
    108 !            DO ji = fs_2, fs_jpim1   ! vector opt. 
    109 !               ua(ji,jj,jk) = ua(ji,jj,jk) - 0.25 * ( + un(ji+1,jj  ,jk) * un(ji+1,jj  ,jk)   & 
    110 !                  &                                   + vn(ji+1,jj-1,jk) * vn(ji+1,jj-1,jk)   & 
    111 !                  &                                   + vn(ji+1,jj  ,jk) * vn(ji+1,jj  ,jk)   & 
    112 !                  ! 
    113 !                  &                                   - un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)   & 
    114 !                  &                                   - vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)   & 
    115 !                  &                                   - vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk)   ) / e1u(ji,jj) 
    116 !                  ! 
    117 !               va(ji,jj,jk) = va(ji,jj,jk) - 0.25 * (   un(ji-1,jj+1,jk) * un(ji-1,jj+1,jk)   & 
    118 !                  &                                   + un(ji  ,jj+1,jk) * un(ji  ,jj+1,jk)   & 
    119 !                  &                                   + vn(ji  ,jj+1,jk) * vn(ji  ,jj+1,jk)   & 
    120 !                  ! 
    121 !                  &                                   - un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)   & 
    122 !                  &                                   - un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk)   & 
    123 !                  &                                   - vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk)   ) / e2v(ji,jj) 
    124 !            END DO  
    125 !         END DO 
    126 !!gm en idea            <<== 
    127          !                                             ! =============== 
    128       END DO                                           !   End of slab 
    129       !                                                ! =============== 
    130  
    131       IF( l_trddyn ) THEN      ! save the Kinetic Energy trends for diagnostic 
     143      END DO 
     144      ! 
     145      IF( l_trddyn ) THEN                 ! save the Kinetic Energy trends for diagnostic 
    132146         ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 
    133147         ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 
    134148         CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt ) 
    135          CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv ) 
     149         CALL wrk_dealloc( jpi,jpj,jpk,   ztrdu, ztrdv ) 
    136150      ENDIF 
    137151      ! 
     
    139153         &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    140154      ! 
    141       CALL wrk_dealloc( jpi, jpj, jpk, zhke ) 
     155      CALL wrk_dealloc( jpi,jpj,jpk,  zhke ) 
    142156      ! 
    143       IF( nn_timing == 1 )  CALL timing_stop('dyn_keg') 
     157      IF( nn_timing == 1 )   CALL timing_stop('dyn_keg') 
    144158      ! 
    145159   END SUBROUTINE dyn_keg 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynnept.F90

    • Property svn:keywords set to Id
    r4792 r5620  
    6969   !!---------------------------------------------------------------------- 
    7070 
     71   !! $Id$ 
    7172 CONTAINS 
    7273 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

    r5038 r5620  
    266266               ! Add volume filter correction: compatibility with tracer advection scheme 
    267267               ! => time filter + conservation correction (only at the first level) 
    268                fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 
    269             ! 
     268               fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 
     269                              &                                          -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 
    270270            ENDIF 
    271271            ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90

    r5038 r5620  
    250250      IF( ( ioptio > 1 .AND. .NOT. lk_esopa ) .OR. ( ioptio == 0 .AND. .NOT. lk_c1d ) )   & 
    251251           &   CALL ctl_stop( ' Choose only one surface pressure gradient scheme with a key cpp' ) 
    252       IF( ( lk_dynspg_ts .OR. lk_dynspg_exp ) .AND. nn_isf .NE. 0 )   & 
     252      IF( ( lk_dynspg_ts .OR. lk_dynspg_exp ) .AND. ln_isfcav )   & 
    253253           &   CALL ctl_stop( ' dynspg_ts and dynspg_exp not tested with ice shelf cavity ' ) 
    254254      ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r5038 r5620  
    2222   USE dom_oce         ! ocean space and time domain 
    2323   USE sbc_oce         ! surface boundary condition: ocean 
     24   USE sbcisf          ! ice shelf variable (fwfisf) 
    2425   USE dynspg_oce      ! surface pressure gradient variables 
    2526   USE phycst          ! physical constants 
     
    7879   !!---------------------------------------------------------------------- 
    7980   !! NEMO/OPA 3.5 , NEMO Consortium (2013) 
    80    !! $Id: dynspg_ts.F90 
     81   !! $Id$ 
    8182   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    8283   !!---------------------------------------------------------------------- 
     
    453454      !                                         ! Surface net water flux and rivers 
    454455      IF (ln_bt_fw) THEN 
    455          zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) ) 
     456         zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) ) 
    456457      ELSE 
    457          zssh_frc(:,:) = zraur * z1_2 * (emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)) 
     458         zssh_frc(:,:) = zraur * z1_2 * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)   & 
     459                &                        + rdivisf * ( fwfisf(:,:) + fwfisf_b(:,:) )       ) 
    458460      ENDIF 
    459461#if defined key_asminc 
    460462      !                                         ! Include the IAU weighted SSH increment 
    461463      IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 
    462          zssh_frc(:,:) = zssh_frc(:,:) + ssh_iau(:,:) 
     464         zssh_frc(:,:) = zssh_frc(:,:) - ssh_iau(:,:) 
    463465      ENDIF 
    464466#endif 
     
    555557               END DO 
    556558            END DO 
    557             CALL lbc_lnk( zwx, 'U', 1._wp )    ;   CALL lbc_lnk( zwy, 'V', 1._wp ) 
     559            CALL lbc_lnk_multi( zwx, 'U', 1._wp, zwy, 'V', 1._wp ) 
    558560            ! 
    559561            zhup2_e (:,:) = hu_0(:,:) + zwx(:,:)                ! Ocean depth at U- and V-points 
     
    633635               END DO 
    634636            END DO 
    635             CALL lbc_lnk( zsshu_a, 'U', 1._wp )   ;   CALL lbc_lnk( zsshv_a, 'V', 1._wp ) 
     637            CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) 
    636638         ENDIF    
    637639         !                                  
     
    801803         !                                                 !  ----------------------- 
    802804         ! 
    803          CALL lbc_lnk( ua_e  , 'U', -1._wp )               ! local domain boundaries  
    804          CALL lbc_lnk( va_e  , 'V', -1._wp ) 
     805         CALL lbc_lnk_multi( ua_e, 'U', -1._wp, va_e , 'V', -1._wp ) 
    805806 
    806807#if defined key_bdy   
     
    857858            END DO 
    858859         END DO 
    859          CALL lbc_lnk( zsshu_a, 'U', 1._wp )   ;   CALL lbc_lnk( zsshv_a, 'V', 1._wp ) ! Boundary conditions 
     860         CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 
    860861      ENDIF 
    861862      ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynzad.F90

    r5038 r5620  
    9595         END DO    
    9696      END DO 
    97       DO jj = 2, jpjm1              ! Surface and bottom values set to zero 
    98          DO ji = fs_2, fs_jpim1           ! vector opt. 
    99             zwuw(ji,jj, 1:miku(ji,jj) ) = 0._wp 
    100             zwvw(ji,jj, 1:mikv(ji,jj) ) = 0._wp 
    101             zwuw(ji,jj,jpk) = 0._wp 
    102             zwvw(ji,jj,jpk) = 0._wp 
    103          END DO   
    104       END DO 
     97      ! 
     98      ! Surface and bottom advective fluxes set to zero 
     99      IF ( ln_isfcav ) THEN 
     100         DO jj = 2, jpjm1 
     101            DO ji = fs_2, fs_jpim1           ! vector opt. 
     102               zwuw(ji,jj, 1:miku(ji,jj) ) = 0._wp 
     103               zwvw(ji,jj, 1:mikv(ji,jj) ) = 0._wp 
     104               zwuw(ji,jj,jpk) = 0._wp 
     105               zwvw(ji,jj,jpk) = 0._wp 
     106            END DO 
     107         END DO 
     108      ELSE 
     109         DO jj = 2, jpjm1         
     110            DO ji = fs_2, fs_jpim1           ! vector opt. 
     111               zwuw(ji,jj, 1 ) = 0._wp 
     112               zwvw(ji,jj, 1 ) = 0._wp 
     113               zwuw(ji,jj,jpk) = 0._wp 
     114               zwvw(ji,jj,jpk) = 0._wp 
     115            END DO   
     116         END DO 
     117      END IF 
    105118 
    106119      DO jk = 1, jpkm1              ! Vertical momentum advection at u- and v-points 
     
    196209         END DO 
    197210      END DO 
    198  
    199       DO jj = 2, jpjm1                    ! Surface and bottom advective fluxes set to zero 
     211      ! 
     212      ! Surface and bottom advective fluxes set to zero 
     213      DO jj = 2, jpjm1         
    200214         DO ji = fs_2, fs_jpim1           ! vector opt. 
    201             zwuw(ji,jj, 1:miku(ji,jj) ) = 0._wp 
    202             zwvw(ji,jj, 1:mikv(ji,jj) ) = 0._wp 
     215            zwuw(ji,jj, 1 ) = 0._wp 
     216            zwvw(ji,jj, 1 ) = 0._wp 
    203217            zwuw(ji,jj,jpk) = 0._wp 
    204218            zwvw(ji,jj,jpk) = 0._wp 
     
    228242            DO jj = 2, jpjm1                 ! vertical momentum advection at w-point 
    229243               DO ji = fs_2, fs_jpim1        ! vector opt. 
    230                   zwuw(ji,jj,jk) = ( zww(ji+1,jj  ,jk) + zww(ji,jj,jk) ) * ( zus(ji,jj,jk-1,jtn)-zus(ji,jj,jk,jtn) ) 
    231                   zwvw(ji,jj,jk) = ( zww(ji  ,jj+1,jk) + zww(ji,jj,jk) ) * ( zvs(ji,jj,jk-1,jtn)-zvs(ji,jj,jk,jtn) ) 
     244                  zwuw(ji,jj,jk) = ( zww(ji+1,jj  ,jk) + zww(ji,jj,jk) ) * ( zus(ji,jj,jk-1,jtn)-zus(ji,jj,jk,jtn) ) !* wumask(ji,jj,jk) 
     245                  zwvw(ji,jj,jk) = ( zww(ji  ,jj+1,jk) + zww(ji,jj,jk) ) * ( zvs(ji,jj,jk-1,jtn)-zvs(ji,jj,jk,jtn) ) !* wvmask(ji,jj,jk) 
    232246               END DO   
    233247            END DO    
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90

    r5038 r5620  
    105105               avmu(ji,jj,ikbu+1) = -bfrua(ji,jj) * fse3uw(ji,jj,ikbu+1) 
    106106               avmv(ji,jj,ikbv+1) = -bfrva(ji,jj) * fse3vw(ji,jj,ikbv+1) 
    107                ikbu = miku(ji,jj)       ! ocean top level at u- and v-points  
    108                ikbv = mikv(ji,jj)       ! (first wet ocean u- and v-points) 
    109                IF (ikbu .GE. 2) avmu(ji,jj,ikbu) = -tfrua(ji,jj) * fse3uw(ji,jj,ikbu) 
    110                IF (ikbv .GE. 2) avmv(ji,jj,ikbv) = -tfrva(ji,jj) * fse3vw(ji,jj,ikbv) 
    111             END DO 
    112          END DO 
     107            END DO 
     108         END DO 
     109         IF ( ln_isfcav ) THEN 
     110            DO jj = 2, jpjm1 
     111               DO ji = 2, jpim1 
     112                  ikbu = miku(ji,jj)       ! ocean top level at u- and v-points  
     113                  ikbv = mikv(ji,jj)       ! (first wet ocean u- and v-points) 
     114                  IF (ikbu .GE. 2) avmu(ji,jj,ikbu) = -tfrua(ji,jj) * fse3uw(ji,jj,ikbu) 
     115                  IF (ikbv .GE. 2) avmv(ji,jj,ikbv) = -tfrva(ji,jj) * fse3vw(ji,jj,ikbv) 
     116               END DO 
     117            END DO 
     118         END IF 
    113119      ENDIF 
    114120 
     
    145151               ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * bfrua(ji,jj) * ua_b(ji,jj) / ze3ua 
    146152               va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * bfrva(ji,jj) * va_b(ji,jj) / ze3va 
    147                ikbu = miku(ji,jj)         ! top ocean level at u- and v-points  
    148                ikbv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
    149                ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,ikbu) + r_vvl   * fse3u_a(ji,jj,ikbu) 
    150                ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,ikbv) + r_vvl   * fse3v_a(ji,jj,ikbv) 
    151                ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * tfrua(ji,jj) * ua_b(ji,jj) / ze3ua 
    152                va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * tfrva(ji,jj) * va_b(ji,jj) / ze3va 
    153             END DO 
    154          END DO 
     153            END DO 
     154         END DO 
     155         IF ( ln_isfcav ) THEN 
     156            DO jj = 2, jpjm1         
     157               DO ji = fs_2, fs_jpim1   ! vector opt. 
     158                  ikbu = miku(ji,jj)         ! top ocean level at u- and v-points  
     159                  ikbv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
     160                  ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,ikbu) + r_vvl   * fse3u_a(ji,jj,ikbu) 
     161                  ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,ikbv) + r_vvl   * fse3v_a(ji,jj,ikbv) 
     162                  ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * tfrua(ji,jj) * ua_b(ji,jj) / ze3ua 
     163                  va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * tfrva(ji,jj) * va_b(ji,jj) / ze3va 
     164               END DO 
     165            END DO 
     166         END IF 
    155167      ENDIF 
    156168#endif 
     
    167179               ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,jk) + r_vvl   * fse3u_a(ji,jj,jk)   ! after scale factor at T-point 
    168180               zcoef = - p2dt / ze3ua       
    169                zzwi          = zcoef * avmu (ji,jj,jk  ) / fse3uw(ji,jj,jk  ) 
    170                zwi(ji,jj,jk) = zzwi  * umask(ji,jj,jk) 
    171                zzws          = zcoef * avmu (ji,jj,jk+1) / fse3uw(ji,jj,jk+1)  
    172                zws(ji,jj,jk) = zzws  * umask(ji,jj,jk+1) 
    173                zwd(ji,jj,jk) = 1._wp - zwi(ji,jj,jk) - zzws 
     181               zzwi          = zcoef * avmu  (ji,jj,jk  ) / fse3uw(ji,jj,jk  ) 
     182               zwi(ji,jj,jk) = zzwi  * wumask(ji,jj,jk  ) 
     183               zzws          = zcoef * avmu  (ji,jj,jk+1) / fse3uw(ji,jj,jk+1)  
     184               zws(ji,jj,jk) = zzws  * wumask(ji,jj,jk+1) 
     185               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    174186            END DO 
    175187         END DO 
     
    198210      ! 
    199211      !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    200       DO jj = 2, jpjm1    
    201          DO ji = fs_2, fs_jpim1   ! vector opt. 
    202             DO jk = miku(ji,jj)+1, jpkm1 
     212      DO jk = 2, jpkm1 
     213         DO jj = 2, jpjm1    
     214            DO ji = fs_2, fs_jpim1   ! vector opt. 
    203215               zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    204216            END DO 
     
    208220      DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
    209221         DO ji = fs_2, fs_jpim1   ! vector opt. 
    210             ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,miku(ji,jj)) + r_vvl   * fse3u_a(ji,jj,miku(ji,jj))  
    211222#if defined key_dynspg_ts 
    212             ua(ji,jj,miku(ji,jj)) = ua(ji,jj,miku(ji,jj)) + p2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
    213                &                                      / ( ze3ua * rau0 )  
     223            ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,1) + r_vvl   * fse3u_a(ji,jj,1)  
     224            ua(ji,jj,1) = ua(ji,jj,1) + p2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
     225               &                                      / ( ze3ua * rau0 ) * umask(ji,jj,1)  
    214226#else 
    215             ua(ji,jj,miku(ji,jj)) = ub(ji,jj,miku(ji,jj)) & 
    216                &                   + p2dt *(ua(ji,jj,miku(ji,jj)) +  0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
    217                &                                  / ( fse3u(ji,jj,miku(ji,jj)) * rau0     ) )  
    218 #endif 
    219             DO jk = miku(ji,jj)+1, jpkm1 
     227            ua(ji,jj,1) = ub(ji,jj,1) & 
     228               &                   + p2dt *(ua(ji,jj,1) +  0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
     229               &                                      / ( fse3u(ji,jj,1) * rau0     ) * umask(ji,jj,1) )  
     230#endif 
     231         END DO 
     232      END DO 
     233      DO jk = 2, jpkm1 
     234         DO jj = 2, jpjm1 
     235            DO ji = fs_2, fs_jpim1 
    220236#if defined key_dynspg_ts 
    221237               zrhs = ua(ji,jj,jk)   ! zrhs=right hand side 
     
    231247         DO ji = fs_2, fs_jpim1   ! vector opt. 
    232248            ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    233             DO jk = jpk-2, miku(ji,jj), -1 
     249         END DO 
     250      END DO 
     251      DO jk = jpk-2, 1, -1 
     252         DO jj = 2, jpjm1 
     253            DO ji = fs_2, fs_jpim1 
    234254               ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
    235255            END DO 
     
    260280               zcoef = - p2dt / ze3va 
    261281               zzwi          = zcoef * avmv (ji,jj,jk  ) / fse3vw(ji,jj,jk  ) 
    262                zwi(ji,jj,jk) =  zzwi * vmask(ji,jj,jk) 
     282               zwi(ji,jj,jk) =  zzwi * wvmask(ji,jj,jk) 
    263283               zzws          = zcoef * avmv (ji,jj,jk+1) / fse3vw(ji,jj,jk+1) 
    264                zws(ji,jj,jk) =  zzws * vmask(ji,jj,jk+1) 
    265                zwd(ji,jj,jk) = 1._wp - zwi(ji,jj,jk) - zzws 
     284               zws(ji,jj,jk) =  zzws * wvmask(ji,jj,jk+1) 
     285               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    266286            END DO 
    267287         END DO 
     
    290310      ! 
    291311      !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    292       DO jj = 2, jpjm1    
    293          DO ji = fs_2, fs_jpim1   ! vector opt. 
    294             DO jk = mikv(ji,jj)+1, jpkm1         
     312      DO jk = 2, jpkm1         
     313         DO jj = 2, jpjm1    
     314            DO ji = fs_2, fs_jpim1   ! vector opt. 
    295315               zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    296316            END DO 
     
    300320      DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
    301321         DO ji = fs_2, fs_jpim1   ! vector opt. 
    302             ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,mikv(ji,jj)) + r_vvl   * fse3v_a(ji,jj,mikv(ji,jj))  
    303322#if defined key_dynspg_ts             
    304             va(ji,jj,mikv(ji,jj)) = va(ji,jj,mikv(ji,jj)) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
     323            ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,1) + r_vvl   * fse3v_a(ji,jj,1)  
     324            va(ji,jj,1) = va(ji,jj,1) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    305325               &                                      / ( ze3va * rau0 )  
    306326#else 
    307             va(ji,jj,mikv(ji,jj)) = vb(ji,jj,mikv(ji,jj)) & 
    308                &                   + p2dt *(va(ji,jj,mikv(ji,jj)) +  0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    309                &                                                       / ( fse3v(ji,jj,mikv(ji,jj)) * rau0     )  ) 
    310 #endif 
    311             DO jk = mikv(ji,jj)+1, jpkm1 
     327            va(ji,jj,1) = vb(ji,jj,1) & 
     328               &                   + p2dt *(va(ji,jj,1) +  0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
     329               &                                                       / ( fse3v(ji,jj,1) * rau0     )  ) 
     330#endif 
     331         END DO 
     332      END DO 
     333      DO jk = 2, jpkm1 
     334         DO jj = 2, jpjm1 
     335            DO ji = fs_2, fs_jpim1   ! vector opt. 
    312336#if defined key_dynspg_ts 
    313337               zrhs = va(ji,jj,jk)   ! zrhs=right hand side 
     
    323347         DO ji = fs_2, fs_jpim1   ! vector opt. 
    324348            va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    325             DO jk = jpk-2, mikv(ji,jj), -1 
     349         END DO 
     350      END DO 
     351      DO jk = jpk-2, 1, -1 
     352         DO jj = 2, jpjm1 
     353            DO ji = fs_2, fs_jpim1 
    326354               va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
    327355            END DO 
     
    349377              avmu(ji,jj,ikbu+1) = 0.e0 
    350378              avmv(ji,jj,ikbv+1) = 0.e0 
    351               ikbu = miku(ji,jj)         ! ocean top level at u- and v-points  
    352               ikbv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
    353               IF (ikbu > 1) avmu(ji,jj,ikbu) = 0.e0 
    354               IF (ikbv > 1) avmv(ji,jj,ikbv) = 0.e0 
    355379           END DO 
    356380        END DO 
     381        IF (ln_isfcav) THEN 
     382           DO jj = 2, jpjm1 
     383              DO ji = 2, jpim1 
     384                 ikbu = miku(ji,jj)         ! ocean top level at u- and v-points  
     385                 ikbv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
     386                 IF (ikbu > 1) avmu(ji,jj,ikbu) = 0.e0 
     387                 IF (ikbv > 1) avmv(ji,jj,ikbv) = 0.e0 
     388              END DO 
     389           END DO 
     390        END IF 
    357391      ENDIF 
    358392      ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

    r5038 r5620  
    2121   USE domvvl          ! Variable volume 
    2222   USE divcur          ! hor. divergence and curl      (div & cur routines) 
    23    USE iom             ! I/O library 
    2423   USE restart         ! only for lrst_oce 
    2524   USE in_out_manager  ! I/O manager 
     
    3130   USE bdy_par          
    3231   USE bdydyn2d        ! bdy_ssh routine 
    33    USE iom 
    3432#if defined key_agrif 
    3533   USE agrif_opa_update 
     
    137135      !                                           !           outputs            ! 
    138136      !                                           !------------------------------! 
    139       CALL iom_put( "ssh" , sshn )   ! sea surface height 
    140       if( iom_use('ssh2') )   CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
    141137      ! 
    142138      IF(ln_ctl)   CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha  - : ', mask1=tmask, ovlap=1 ) 
     
    228224#endif 
    229225      ! 
    230       !                                           !------------------------------! 
    231       !                                           !           outputs            ! 
    232       !                                           !------------------------------! 
    233       CALL iom_put( "woce", wn )   ! vertical velocity 
    234       IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN   ! vertical mass transport & its square value 
    235          CALL wrk_alloc( jpi, jpj, z2d )  
    236          CALL wrk_alloc( jpi, jpj, jpk, z3d )  
    237          ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 
    238          z2d(:,:) = rau0 * e12t(:,:) 
    239          DO jk = 1, jpk 
    240             z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) 
    241          END DO 
    242          CALL iom_put( "w_masstr" , z3d )   
    243          IF( iom_use('w_masstr2') )   CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 
    244          CALL wrk_dealloc( jpi, jpj, z2d  )  
    245          CALL wrk_dealloc( jpi, jpj, jpk, z3d )  
    246       ENDIF 
    247       ! 
    248226      IF( nn_timing == 1 )  CALL timing_stop('wzv') 
    249227 
     
    290268      ELSE                                         !** Leap-Frog time-stepping: Asselin filter + swap 
    291269         sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) )     ! before <-- now filtered 
    292          IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) ) * ssmask(:,:) 
     270         IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) - rnf_b(:,:) + rnf(:,:) ) * ssmask(:,:) 
    293271         sshn(:,:) = ssha(:,:)                           ! now <-- after 
    294272      ENDIF 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/FLO/florst.F90

    • Property svn:keywords set to Id
    r3294 r5620  
    3636   !!---------------------------------------------------------------------- 
    3737   !! NEMO/OPA 3.2 , LODYC-IPSL  (2009) 
    38    !! $Header: 
     38   !! $Id$ 
    3939   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    4040   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/FLO/flowri.F90

    r3294 r5620  
    5050   !!---------------------------------------------------------------------- 
    5151   !! NEMO/OPA 3.2 , LODYC-IPSL  (2009) 
    52    !! $Header: 
     52   !! $Id$ 
    5353   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5454   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icb_oce.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    146146   !!---------------------------------------------------------------------- 
    147147   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    148    !! $Id: sbc_oce.F90 3340 2012-04-02 11:05:35Z sga $ 
     148   !! $Id$ 
    149149   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    150150   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbclv.F90

    • Property svn:keywords set to Id
    r3821 r5620  
    3333   !!---------------------------------------------------------------------- 
    3434   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    35    !! $Id:$ 
     35   !! $Id$ 
    3636   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3737   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbdia.F90

    • Property svn:keywords set to Id
    r3614 r5620  
    7676   !!---------------------------------------------------------------------- 
    7777   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    78    !! $Id:$ 
     78   !! $Id$ 
    7979   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    8080   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbdyn.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    2828   !!---------------------------------------------------------------------- 
    2929   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    30    !! $Id:$ 
     30   !! $Id$ 
    3131   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3232   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    4141   !!---------------------------------------------------------------------- 
    4242   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    43    !! $Id:$ 
     43   !! $Id$ 
    4444   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4545   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    6767   !!---------------------------------------------------------------------- 
    6868   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    69    !! $Id:$ 
     69   !! $Id$ 
    7070   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    7171   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbrst.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    4242   !!---------------------------------------------------------------------- 
    4343   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    44    !! $Id:$ 
     44   !! $Id$ 
    4545   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4646   !!---------------------------------------------------------------------- 
     
    6464                                                                                            ! start and count arrays 
    6565      LOGICAL                      ::   ll_found_restart 
     66      CHARACTER(len=256)           ::   cl_path 
    6667      CHARACTER(len=256)           ::   cl_filename 
    6768      CHARACTER(len=NF90_MAX_NAME) ::   cl_dname 
     
    7071      !!---------------------------------------------------------------------- 
    7172 
    72       ! Find a restart file 
     73      ! Find a restart file. Assume iceberg restarts in same directory as ocean restarts.  
     74      cl_path = TRIM(cn_ocerst_indir) 
     75      IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' 
    7376      cl_filename = ' ' 
    7477      IF ( lk_mpp ) THEN 
    7578         cl_filename = ' ' 
    7679         WRITE( cl_filename, '("restart_icebergs_",I4.4,".nc")' ) narea-1 
    77          INQUIRE( file=TRIM(cl_filename), exist=ll_found_restart ) 
     80         INQUIRE( file=TRIM(cl_path)//TRIM(cl_filename), exist=ll_found_restart ) 
    7881      ELSE 
    7982         cl_filename = 'restart_icebergs.nc' 
    80          INQUIRE( file=TRIM(cl_filename), exist=ll_found_restart ) 
     83         INQUIRE( file=TRIM(cl_path)//TRIM(cl_filename), exist=ll_found_restart ) 
    8184      ENDIF 
    8285 
     
    8689 
    8790      IF (nn_verbose_level >= 0 .AND. lwp)  & 
    88          WRITE(numout,'(2a)') 'icebergs, read_restart_bergs: found restart file = ',TRIM(cl_filename) 
    89  
    90       nret = NF90_OPEN(TRIM(cl_filename), NF90_NOWRITE, ncid) 
     91         WRITE(numout,'(2a)') 'icebergs, read_restart_bergs: found restart file = ',TRIM(cl_path)//TRIM(cl_filename) 
     92 
     93      nret = NF90_OPEN(TRIM(cl_path)//TRIM(cl_filename), NF90_NOWRITE, ncid) 
    9194      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart_bergs: nf_open failed') 
    9295 
     
    228231      INTEGER ::   jn   ! dummy loop index 
    229232      INTEGER ::   ix_dim, iy_dim, ik_dim, in_dim 
     233      CHARACTER(len=256)     :: cl_path 
    230234      CHARACTER(len=256)     :: cl_filename 
    231235      TYPE(iceberg), POINTER :: this 
     
    233237      !!---------------------------------------------------------------------- 
    234238 
     239      ! Assume we write iceberg restarts to same directory as ocean restarts. 
     240      cl_path = TRIM(cn_ocerst_outdir) 
     241      IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' 
    235242      IF( lk_mpp ) THEN 
    236          WRITE(cl_filename,'("icebergs_",I8.8,"_restart_",I4.4,".nc")') kt, narea-1 
     243         WRITE(cl_filename,'(A,"_icebergs_",I8.8,"_restart_",I4.4,".nc")') TRIM(cexper), kt, narea-1 
    237244      ELSE 
    238          WRITE(cl_filename,'("icebergs_",I8.8,"_restart.nc")') kt 
    239       ENDIF 
    240       IF (nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, write_restart: creating ',TRIM(cl_filename) 
    241  
    242       nret = NF90_CREATE(TRIM(cl_filename), NF90_CLOBBER, ncid) 
     245         WRITE(cl_filename,'(A,"_icebergs_",I8.8,"_restart.nc")') TRIM(cexper), kt 
     246      ENDIF 
     247      IF (nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, write_restart: creating ',TRIM(cl_path)//TRIM(cl_filename) 
     248 
     249      nret = NF90_CREATE(TRIM(cl_path)//TRIM(cl_filename), NF90_CLOBBER, ncid) 
    243250      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_create failed') 
    244251 
     
    372379         ENDIF 
    373380      ENDDO 
    374       IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_filename),' var: stored_ice  written' 
     381      IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_ice  written' 
    375382 
    376383      nret = NF90_PUT_VAR( ncid, nkountid, num_bergs(:) ) 
     
    379386      nret = NF90_PUT_VAR( ncid, nsheatid, berg_grid%stored_heat(:,:) ) 
    380387      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var stored_heat failed') 
    381       IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_filename),' var: stored_heat written' 
     388      IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_heat written' 
    382389 
    383390      nret = NF90_PUT_VAR( ncid, ncalvid , src_calving(:,:) ) 
     
    385392      nret = NF90_PUT_VAR( ncid, ncalvhid, src_calving_hflx(:,:) ) 
    386393      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving_hflx failed') 
    387       IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_filename),' var: calving written' 
     394      IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: calving written' 
    388395 
    389396      IF ( ASSOCIATED(first_berg) ) THEN 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbstp.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    4646   !!---------------------------------------------------------------------- 
    4747   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    48    !! $Id:$ 
     48   !! $Id$ 
    4949   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    5050   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbthm.F90

    • Property svn:keywords set to Id
    r3631 r5620  
    3131   PUBLIC   icb_thm ! routine called in icbstp.F90 module 
    3232 
     33   !! $Id$ 
    3334CONTAINS 
    3435 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbtrj.F90

    • Property svn:keywords set to Id
    r3614 r5620  
    4444   !!---------------------------------------------------------------------- 
    4545   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    46    !! $Id:$ 
     46   !! $Id$ 
    4747   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4848   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbutl.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    5151   !!---------------------------------------------------------------------- 
    5252   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    53    !! $Id:$ 
     53   !! $Id$ 
    5454   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    5555   !!------------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90

    r5038 r5620  
    2626   CHARACTER(lc) ::   cn_exp           !: experiment name used for output filename 
    2727   CHARACTER(lc) ::   cn_ocerst_in     !: suffix of ocean restart name (input) 
     28   CHARACTER(lc) ::   cn_ocerst_indir  !: restart input directory 
    2829   CHARACTER(lc) ::   cn_ocerst_out    !: suffix of ocean restart name (output) 
     30   CHARACTER(lc) ::   cn_ocerst_outdir !: restart output directory 
    2931   LOGICAL       ::   ln_rstart        !: start from (F) rest or (T) a restart file 
     32   LOGICAL       ::   ln_rst_list      !: output restarts at list of times (T) or by frequency (F) 
    3033   INTEGER       ::   nn_no            !: job number 
    3134   INTEGER       ::   nn_rstctl        !: control of the time step (0, 1 or 2) 
     
    3841   INTEGER       ::   nn_write         !: model standard output frequency 
    3942   INTEGER       ::   nn_stock         !: restart file frequency 
     43   INTEGER, DIMENSION(10) :: nn_stocklist  !: restart dump times 
    4044   LOGICAL       ::   ln_dimgnnn       !: type of dimgout. (F): 1 file for all proc 
    4145                                                       !:                  (T): 1 file per proc 
    4246   LOGICAL       ::   ln_mskland       !: mask land points in NetCDF outputs (costly: + ~15%) 
     47   LOGICAL       ::   ln_cfmeta        !: output additional data to netCDF files required for compliance with the CF metadata standard 
    4348   LOGICAL       ::   ln_clobber       !: clobber (overwrite) an existing file 
    4449   INTEGER       ::   nn_chunksz       !: chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) 
     
    7883   INTEGER       ::   nwrite                      !: model standard output frequency 
    7984   INTEGER       ::   nstock                      !: restart file frequency 
     85   INTEGER, DIMENSION(10) :: nstocklist           !: restart dump times 
    8086 
    8187   !!---------------------------------------------------------------------- 
     
    8490   INTEGER ::   nitrst                !: time step at which restart file should be written 
    8591   LOGICAL ::   lrst_oce              !: logical to control the oce restart write  
    86    INTEGER ::   numror, numrow        !: logical unit for cean restart (read and write) 
     92   INTEGER ::   numror = 0            !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) 
     93   INTEGER ::   numrow                !: logical unit for ocean restart (write) 
     94   INTEGER ::   nrst_lst              !: number of restart to output next 
    8795 
    8896   !!---------------------------------------------------------------------- 
     
    142150   LOGICAL       ::   lwp      = .FALSE.    !: boolean : true on the 1st processor only .OR. ln_ctl 
    143151   LOGICAL       ::   lsp_area = .TRUE.     !: to make a control print over a specific area 
     152   CHARACTER(lc) ::   cxios_context         !: context name used in xios 
    144153 
    145154   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r5038 r5620  
    3333   USE icb_oce, ONLY :   nclasses, class_num       !  !: iceberg classes 
    3434#if defined key_lim3 
    35    USE par_ice 
     35   USE ice    , ONLY :   jpl 
    3636#elif defined key_lim2 
    3737   USE par_ice_2 
     
    6161#if defined key_iomput 
    6262   PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr 
    63    PRIVATE set_grid, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate 
     63   PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate 
    6464# endif 
    6565 
     
    9898      CHARACTER(len=10) :: clname 
    9999      INTEGER           ::   ji 
    100       !!---------------------------------------------------------------------- 
     100      ! 
     101      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 
     102      !!---------------------------------------------------------------------- 
     103 
     104      ALLOCATE( z_bnds(jpk,2) ) 
    101105 
    102106      clname = cdname 
    103107      IF( TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(cdname) 
    104 # if defined key_mpp_mpi 
    105108      CALL xios_context_initialize(TRIM(clname), mpi_comm_opa) 
    106 # else 
    107       CALL xios_context_initialize(TRIM(clname), 0) 
    108 # endif 
    109109      CALL iom_swap( cdname ) 
    110110 
     
    121121      CALL set_scalar 
    122122 
    123       IF( TRIM(cdname) == "nemo" ) THEN   
     123      IF( TRIM(cdname) == TRIM(cxios_context) ) THEN   
    124124         CALL set_grid( "T", glamt, gphit )  
    125125         CALL set_grid( "U", glamu, gphiu ) 
    126126         CALL set_grid( "V", glamv, gphiv ) 
    127127         CALL set_grid( "W", glamt, gphit ) 
    128       ENDIF 
    129  
    130       IF( TRIM(cdname) == "nemo_crs" ) THEN   
     128         CALL set_grid_znl( gphit ) 
     129         ! 
     130         IF( ln_cfmeta ) THEN   ! Add additional grid metadata 
     131            CALL iom_set_domain_attr("grid_T", area = e12t(nldi:nlei, nldj:nlej)) 
     132            CALL iom_set_domain_attr("grid_U", area = e12u(nldi:nlei, nldj:nlej)) 
     133            CALL iom_set_domain_attr("grid_V", area = e12v(nldi:nlei, nldj:nlej)) 
     134            CALL iom_set_domain_attr("grid_W", area = e12t(nldi:nlei, nldj:nlej)) 
     135            CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 
     136            CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) 
     137            CALL set_grid_bounds( "V", glamu, gphiu, glamv, gphiv ) 
     138            CALL set_grid_bounds( "W", glamf, gphif, glamt, gphit ) 
     139         ENDIF 
     140      ENDIF 
     141 
     142      IF( TRIM(cdname) == TRIM(cxios_context)//"_crs" ) THEN   
    131143         CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    132144         ! 
     
    135147         CALL set_grid( "V", glamv_crs, gphiv_crs )  
    136148         CALL set_grid( "W", glamt_crs, gphit_crs )  
     149         CALL set_grid_znl( gphit_crs ) 
    137150          ! 
    138151         CALL dom_grid_glo   ! Return to parent grid domain 
    139       ENDIF 
    140  
     152         ! 
     153         IF( ln_cfmeta ) THEN   ! Add additional grid metadata 
     154            CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej)) 
     155            CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej)) 
     156            CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej)) 
     157            CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej)) 
     158            CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 
     159            CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) 
     160            CALL set_grid_bounds( "V", glamu_crs, gphiu_crs, glamv_crs, gphiv_crs ) 
     161            CALL set_grid_bounds( "W", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 
     162         ENDIF 
     163      ENDIF 
    141164 
    142165      ! vertical grid definition 
     
    145168      CALL iom_set_axis_attr( "depthv", gdept_1d ) 
    146169      CALL iom_set_axis_attr( "depthw", gdepw_1d ) 
     170 
     171      ! Add vertical grid bounds 
     172      z_bnds(:      ,1) = gdepw_1d(:) 
     173      z_bnds(1:jpkm1,2) = gdepw_1d(2:jpk) 
     174      z_bnds(jpk:   ,2) = gdepw_1d(jpk) + e3t_1d(jpk) 
     175      CALL iom_set_axis_attr( "deptht", bounds=z_bnds ) 
     176      CALL iom_set_axis_attr( "depthu", bounds=z_bnds ) 
     177      CALL iom_set_axis_attr( "depthv", bounds=z_bnds ) 
     178      z_bnds(:    ,2) = gdept_1d(:) 
     179      z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 
     180      z_bnds(1    ,1) = gdept_1d(1) - e3w_1d(1) 
     181      CALL iom_set_axis_attr( "depthw", bounds=z_bnds ) 
     182 
    147183# if defined key_floats 
    148184      CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) 
     
    152188#endif 
    153189      CALL iom_set_axis_attr( "icbcla", class_num ) 
     190      CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) 
     191      CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) 
    154192       
    155193      ! automatic definitions of some of the xml attributs 
     
    162200       
    163201      CALL xios_update_calendar(0) 
     202 
     203      DEALLOCATE( z_bnds ) 
     204 
    164205#endif 
    165206       
     
    543584   END SUBROUTINE iom_g1d 
    544585 
    545    SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 
     586   SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) 
    546587      INTEGER         , INTENT(in   )                           ::   kiomid    ! Identifier of the file 
    547588      INTEGER         , INTENT(in   )                           ::   kdom      ! Type of domain to be read 
     
    551592      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kstart    ! start axis position of the reading  
    552593      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kcount    ! number of points in each axis 
     594      LOGICAL         , INTENT(in   )                , OPTIONAL ::   lrowattr  ! logical flag telling iom_get to 
     595                                                                               ! look for and use a file attribute 
     596                                                                               ! called open_ocean_jstart to set the start 
     597                                                                               ! value for the 2nd dimension (netcdf only) 
    553598      ! 
    554599      IF( kiomid > 0 ) THEN 
    555600         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r2d=pvar,   & 
    556               &                                                     ktime=ktime, kstart=kstart, kcount=kcount ) 
     601              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
     602              &                                                     lrowattr=lrowattr ) 
    557603      ENDIF 
    558604   END SUBROUTINE iom_g2d 
    559605 
    560    SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 
     606   SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) 
    561607      INTEGER         , INTENT(in   )                             ::   kiomid    ! Identifier of the file 
    562608      INTEGER         , INTENT(in   )                             ::   kdom      ! Type of domain to be read 
     
    566612      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kstart    ! start axis position of the reading  
    567613      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kcount    ! number of points in each axis 
     614      LOGICAL         , INTENT(in   )                  , OPTIONAL ::   lrowattr  ! logical flag telling iom_get to 
     615                                                                                 ! look for and use a file attribute 
     616                                                                                 ! called open_ocean_jstart to set the start 
     617                                                                                 ! value for the 2nd dimension (netcdf only) 
    568618      ! 
    569619      IF( kiomid > 0 ) THEN 
    570620         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r3d=pvar,   & 
    571               &                                                     ktime=ktime, kstart=kstart, kcount=kcount ) 
     621              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
     622              &                                                     lrowattr=lrowattr ) 
    572623      ENDIF 
    573624   END SUBROUTINE iom_g3d 
     
    576627   SUBROUTINE iom_get_123d( kiomid, kdom  , cdvar ,   & 
    577628         &                  pv_r1d, pv_r2d, pv_r3d,   & 
    578          &                  ktime , kstart, kcount  ) 
     629         &                  ktime , kstart, kcount,   & 
     630         &                  lrowattr                ) 
    579631      !!----------------------------------------------------------------------- 
    580632      !!                  ***  ROUTINE  iom_get_123d  *** 
     
    593645      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kstart     ! start position of the reading in each axis  
    594646      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kcount     ! number of points to be read in each axis 
     647      LOGICAL                    , INTENT(in   ), OPTIONAL ::   lrowattr   ! logical flag telling iom_get to 
     648                                                                           ! look for and use a file attribute 
     649                                                                           ! called open_ocean_jstart to set the start 
     650                                                                           ! value for the 2nd dimension (netcdf only) 
    595651      ! 
    596652      LOGICAL                        ::   llnoov      ! local definition to read overlap 
     653      LOGICAL                        ::   luse_jattr  ! local definition to read open_ocean_jstart file attribute 
     654      INTEGER                        ::   jstartrow   ! start point for 2nd dimension optionally set by file attribute 
    597655      INTEGER                        ::   jl          ! loop on number of dimension  
    598656      INTEGER                        ::   idom        ! type of domain 
     
    604662      INTEGER                        ::   ix1, ix2, iy1, iy2   ! subdomain indexes 
    605663      INTEGER                        ::   ji, jj      ! loop counters 
    606       INTEGER                        ::   irankpv       !  
     664      INTEGER                        ::   irankpv     !  
    607665      INTEGER                        ::   ind1, ind2  ! substring index 
    608666      INTEGER, DIMENSION(jpmax_dims) ::   istart      ! starting point to read for each axis 
     
    628686      IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 
    629687      IF( PRESENT(kstart) .AND. idom /= jpdom_unknown   ) CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown') 
     688 
     689      luse_jattr = .false. 
     690      IF( PRESENT(lrowattr) ) THEN 
     691         IF( lrowattr .AND. idom /= jpdom_data   ) CALL ctl_stop(trim(clinfo), 'lrowattr present and true needs kdom = jpdom_data') 
     692         IF( lrowattr .AND. idom == jpdom_data   ) luse_jattr = .true. 
     693      ENDIF 
     694      IF( luse_jattr ) THEN 
     695         SELECT CASE (iom_file(kiomid)%iolib) 
     696         CASE (jpioipsl, jprstdimg ) 
     697             CALL ctl_warn(trim(clinfo), 'lrowattr present and true but this only works with netcdf (jpnf90)') 
     698             luse_jattr = .false. 
     699         CASE (jpnf90   )    
     700             ! Ok 
     701         CASE DEFAULT     
     702            CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 
     703         END SELECT 
     704      ENDIF 
    630705 
    631706      ! Search for the variable in the data base (eventually actualize data) 
     
    701776            ELSE  
    702777               IF( .NOT. PRESENT(pv_r1d) ) THEN   !   not a 1D array 
    703                   IF(     idom == jpdom_data    ) THEN ; istart(1:2) = (/ mig(1), mjg(1) /)  ! icnt(1:2) done bellow 
    704                   ELSEIF( idom == jpdom_global  ) THEN ; istart(1:2) = (/ nimpp , njmpp  /)  ! icnt(1:2) done bellow 
     778                  IF(     idom == jpdom_data    ) THEN 
     779                     jstartrow = 1 
     780                     IF( luse_jattr ) THEN 
     781                        CALL iom_getatt(kiomid, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 
     782                        jstartrow = MAX(1,jstartrow) 
     783                     ENDIF 
     784                     istart(1:2) = (/ mig(1), mjg(1) + jstartrow - 1 /)  ! icnt(1:2) done below 
     785                  ELSEIF( idom == jpdom_global  ) THEN ; istart(1:2) = (/ nimpp , njmpp  /)  ! icnt(1:2) done below 
    705786                  ENDIF 
    706787                  ! we do not read the overlap                     -> we start to read at nldi, nldj 
     
    10901171 
    10911172   SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj,   & 
    1092       &                                    data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask ) 
    1093       CHARACTER(LEN=*)                 , INTENT(in) ::   cdid 
    1094       INTEGER                , OPTIONAL, INTENT(in) ::   ni_glo, nj_glo, ibegin, jbegin, ni, nj 
    1095       INTEGER                , OPTIONAL, INTENT(in) ::   data_dim, data_ibegin, data_ni, data_jbegin, data_nj 
    1096       INTEGER                , OPTIONAL, INTENT(in) ::   zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj 
    1097       REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
    1098       LOGICAL, DIMENSION(:,:), OPTIONAL, INTENT(in) ::   mask 
     1173      &                                    data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask,     & 
     1174      &                                    nvertex, bounds_lon, bounds_lat, area ) 
     1175      CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
     1176      INTEGER                  , OPTIONAL, INTENT(in) ::   ni_glo, nj_glo, ibegin, jbegin, ni, nj 
     1177      INTEGER                  , OPTIONAL, INTENT(in) ::   data_dim, data_ibegin, data_ni, data_jbegin, data_nj 
     1178      INTEGER                  , OPTIONAL, INTENT(in) ::   zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, nvertex 
     1179      REAL(wp), DIMENSION(:)   , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
     1180      REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
     1181      LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
    10991182 
    11001183      IF ( xios_is_valid_domain     (cdid) ) THEN 
     
    11021185            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
    11031186            &    zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj,                       & 
    1104             &    lonvalue=lonvalue, latvalue=latvalue,mask=mask ) 
     1187            &    lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon,                  & 
     1188            &    bounds_lat=bounds_lat, area=area ) 
    11051189      ENDIF 
    11061190 
     
    11091193            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
    11101194            &    zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj,                       & 
    1111             &    lonvalue=lonvalue, latvalue=latvalue,mask=mask ) 
     1195            &    lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon,                  & 
     1196            &    bounds_lat=bounds_lat, area=area ) 
    11121197      ENDIF 
    11131198      CALL xios_solve_inheritance() 
     
    11161201 
    11171202 
    1118    SUBROUTINE iom_set_axis_attr( cdid, paxis ) 
     1203   SUBROUTINE iom_set_axis_attr( cdid, paxis, bounds ) 
    11191204      CHARACTER(LEN=*)      , INTENT(in) ::   cdid 
    1120       REAL(wp), DIMENSION(:), INTENT(in) ::   paxis 
    1121       IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=size(paxis),value=paxis ) 
    1122       IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, size=size(paxis),value=paxis ) 
     1205      REAL(wp), DIMENSION(:)  , OPTIONAL, INTENT(in) ::   paxis 
     1206      REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds 
     1207      IF ( PRESENT(paxis) ) THEN 
     1208         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=SIZE(paxis), value=paxis ) 
     1209         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, size=SIZE(paxis), value=paxis ) 
     1210      ENDIF 
     1211      IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=bounds ) 
     1212      IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 
    11231213      CALL xios_solve_inheritance() 
    11241214   END SUBROUTINE iom_set_axis_attr 
     
    11831273      CALL iom_swap( cdname )   ! swap to cdname context 
    11841274      CALL xios_update_calendar(kt) 
    1185       IF( cdname /= "nemo" ) CALL iom_swap( "nemo" )   ! return back to nemo context 
     1275      IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context 
    11861276      ! 
    11871277   END SUBROUTINE iom_setkt 
     
    11931283         CALL iom_swap( cdname )   ! swap to cdname context 
    11941284         CALL xios_context_finalize() ! finalize the context 
    1195          IF( cdname /= "nemo" ) CALL iom_swap( "nemo" )   ! return back to nemo context 
     1285         IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context 
    11961286      ENDIF 
    11971287      ! 
     
    12251315         CASE('T')   ;   zmask(:,:,:)       = tmask(:,:,:) 
    12261316         CASE('U')   ;   zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:)   ;   CALL lbc_lnk( zmask, 'U', 1. ) 
    1227          CASE('V')   ;   zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpi,:)   ;   CALL lbc_lnk( zmask, 'V', 1. ) 
     1317         CASE('V')   ;   zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:)   ;   CALL lbc_lnk( zmask, 'V', 1. ) 
    12281318         CASE('W')   ;   zmask(:,:,2:jpk  ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk)   ;   zmask(:,:,1) = tmask(:,:,1) 
    12291319         END SELECT 
     
    12361326 
    12371327 
     1328   SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt ) 
     1329      !!---------------------------------------------------------------------- 
     1330      !!                   ***  ROUTINE set_grid_bounds  *** 
     1331      !! 
     1332      !! ** Purpose :   define horizontal grid corners 
     1333      !! 
     1334      !!---------------------------------------------------------------------- 
     1335      CHARACTER(LEN=1) , INTENT(in) :: cdgrd 
     1336      ! 
     1337      REAL(wp), DIMENSION(jpi,jpj), INTENT(in)           :: plon_cnr, plat_cnr  ! Lat/lon coordinates of a contiguous vertex of cell (i,j) 
     1338      REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt  ! Lat/lon coordinates of the point of cell (i,j) 
     1339      ! 
     1340      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:)   :: z_bnds      ! Lat/lon coordinates of the vertices of cell (i,j) 
     1341      REAL(wp), ALLOCATABLE, DIMENSION(:,:)       :: z_fld       ! Working array to determine where to rotate cells 
     1342      REAL(wp), ALLOCATABLE, DIMENSION(:,:)       :: z_rot       ! Lat/lon working array for rotation of cells 
     1343      ! 
     1344      INTEGER :: icnr, jcnr                                      ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 
     1345      !                                                          ! represents the bottom-left corner of cell (i,j) 
     1346      INTEGER :: ji, jj, jn, ni, nj 
     1347 
     1348      ALLOCATE( z_bnds(4,jpi,jpj,2), z_fld(jpi,jpj), z_rot(4,2)  ) 
     1349 
     1350      ! Offset of coordinate representing bottom-left corner 
     1351      SELECT CASE ( TRIM(cdgrd) ) 
     1352         CASE ('T', 'W') 
     1353            icnr = -1 ; jcnr = -1 
     1354         CASE ('U') 
     1355            icnr =  0 ; jcnr = -1 
     1356         CASE ('V') 
     1357            icnr = -1 ; jcnr =  0 
     1358      END SELECT 
     1359 
     1360      ni = nlei-nldi+1 ; nj = nlej-nldj+1  ! Dimensions of subdomain interior 
     1361 
     1362      z_fld(:,:) = 1._wp 
     1363      CALL lbc_lnk( z_fld, cdgrd, -1. )    ! Working array for location of northfold 
     1364 
     1365      ! Cell vertices that can be defined 
     1366      DO jj = 2, jpjm1 
     1367         DO ji = 2, jpim1 
     1368            z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr,  jj+jcnr  ) ! Bottom-left 
     1369            z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr  ) ! Bottom-right 
     1370            z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 
     1371            z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr,  jj+jcnr+1) ! Top-left 
     1372            z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr,  jj+jcnr  ) ! Bottom-left 
     1373            z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr  ) ! Bottom-right 
     1374            z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 
     1375            z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr,  jj+jcnr+1) ! Top-left 
     1376         END DO 
     1377      END DO 
     1378 
     1379      ! Cell vertices on boundries 
     1380      DO jn = 1, 4 
     1381         CALL lbc_lnk( z_bnds(jn,:,:,1), cdgrd, 1., pval=999._wp ) 
     1382         CALL lbc_lnk( z_bnds(jn,:,:,2), cdgrd, 1., pval=999._wp ) 
     1383      END DO 
     1384 
     1385      ! Zero-size cells at closed boundaries if cell points provided, 
     1386      ! otherwise they are closed cells with unrealistic bounds 
     1387      IF( PRESENT(plon_pnt) .AND. PRESENT(plat_pnt) ) THEN 
     1388         IF( (nbondi == -1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 
     1389            DO jn = 1, 4        ! (West or jpni = 1), closed E-W 
     1390               z_bnds(jn,1,:,1) = plat_pnt(1,:)  ;  z_bnds(jn,1,:,2) = plon_pnt(1,:) 
     1391            END DO 
     1392         ENDIF 
     1393         IF( (nbondi == 1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 
     1394            DO jn = 1, 4        ! (East or jpni = 1), closed E-W 
     1395               z_bnds(jn,nlci,:,1) = plat_pnt(nlci,:)  ;  z_bnds(jn,nlci,:,2) = plon_pnt(nlci,:) 
     1396            END DO 
     1397         ENDIF 
     1398         IF( nbondj == -1 .OR. (nbondj == 2 .AND. jperio /= 2) ) THEN 
     1399            DO jn = 1, 4        ! South or (jpnj = 1, not symmetric) 
     1400               z_bnds(jn,:,1,1) = plat_pnt(:,1)  ;  z_bnds(jn,:,1,2) = plon_pnt(:,1) 
     1401            END DO 
     1402         ENDIF 
     1403         IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio  < 3 ) THEN 
     1404            DO jn = 1, 4        ! (North or jpnj = 1), no north fold 
     1405               z_bnds(jn,:,nlcj,1) = plat_pnt(:,nlcj)  ;  z_bnds(jn,:,nlcj,2) = plon_pnt(:,nlcj) 
     1406            END DO 
     1407         ENDIF 
     1408      ENDIF 
     1409 
     1410      ! Rotate cells at the north fold 
     1411      IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN 
     1412         DO jj = 1, jpj 
     1413            DO ji = 1, jpi 
     1414               IF( z_fld(ji,jj) == -1. ) THEN 
     1415                  z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) 
     1416                  z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) 
     1417                  z_bnds(:,ji,jj,:) = z_rot(:,:) 
     1418               ENDIF 
     1419            END DO 
     1420         END DO 
     1421 
     1422      ! Invert cells at the symmetric equator 
     1423      ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN 
     1424         DO ji = 1, jpi 
     1425            z_rot(1:2,:) = z_bnds(3:4,ji,1,:) 
     1426            z_rot(3:4,:) = z_bnds(1:2,ji,1,:) 
     1427            z_bnds(:,ji,1,:) = z_rot(:,:) 
     1428         END DO 
     1429      ENDIF 
     1430 
     1431      CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)),           & 
     1432                                               bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 ) 
     1433 
     1434      DEALLOCATE( z_bnds, z_fld, z_rot )  
     1435 
     1436   END SUBROUTINE set_grid_bounds 
     1437 
     1438 
     1439   SUBROUTINE set_grid_znl( plat ) 
     1440      !!---------------------------------------------------------------------- 
     1441      !!                     ***  ROUTINE set_grid_znl  *** 
     1442      !! 
     1443      !! ** Purpose :   define grids for zonal mean 
     1444      !! 
     1445      !!---------------------------------------------------------------------- 
     1446      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   plat 
     1447      ! 
     1448      REAL(wp), DIMENSION(:), ALLOCATABLE  ::   zlon 
     1449      INTEGER  :: ni,nj, ix, iy 
     1450 
     1451       
     1452      ni=nlei-nldi+1 ; nj=nlej-nldj+1            ! define zonal mean domain (jpj*jpk) 
     1453      ALLOCATE( zlon(ni*nj) )       ;       zlon(:) = 0. 
     1454 
     1455      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
     1456      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
     1457      CALL iom_set_domain_attr("gznl", lonvalue = zlon,   & 
     1458         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
     1459      ! 
     1460      CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
     1461      CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 
     1462      CALL iom_update_file_name('ptr') 
     1463      ! 
     1464   END SUBROUTINE set_grid_znl 
     1465 
    12381466   SUBROUTINE set_scalar 
    12391467      !!---------------------------------------------------------------------- 
     
    12431471      !! 
    12441472      !!---------------------------------------------------------------------- 
    1245       REAL(wp), DIMENSION(1) ::   zz = 1. 
     1473      REAL(wp), DIMENSION(1)   ::   zz = 1. 
    12461474      !!---------------------------------------------------------------------- 
    12471475      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 
    12481476      CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 
     1477       
    12491478      zz=REAL(narea,wp) 
    12501479      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 
     
    13191548      zlatpira = (/ -19.0, -14.0,  -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /) 
    13201549      CALL set_mooring( zlonpira, zlatpira ) 
     1550 
    13211551       
    13221552   END SUBROUTINE set_xmlatt 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/IOM/iom_nf90.F90

    r4792 r5620  
    6161      INTEGER, DIMENSION(2,5), INTENT(in   ), OPTIONAL ::   kdompar     ! domain parameters:  
    6262 
    63       CHARACTER(LEN=100) ::   clinfo           ! info character 
    64       CHARACTER(LEN=100) ::   cltmp            ! temporary character 
     63      CHARACTER(LEN=256) ::   clinfo           ! info character 
     64      CHARACTER(LEN=256) ::   cltmp            ! temporary character 
    6565      INTEGER            ::   iln              ! lengths of character 
    6666      INTEGER            ::   istop            ! temporary storage of nstop 
     
    422422      INTEGER, DIMENSION(4) :: idimsz               ! dimensions size   
    423423      INTEGER, DIMENSION(4) :: idimid               ! dimensions id 
    424       CHARACTER(LEN=100)    :: clinfo               ! info character 
     424      CHARACTER(LEN=256)    :: clinfo               ! info character 
    425425      CHARACTER(LEN= 12), DIMENSION(4) :: cltmp     ! temporary character 
    426426      INTEGER               :: if90id               ! nf90 file identifier 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90

    r5038 r5620  
    2424   USE trdmxl_oce      ! ocean active mixed layer tracers trends variables 
    2525   USE divcur          ! hor. divergence and curl      (div & cur routines) 
    26    USE sbc_ice, ONLY : lk_lim3 
    2726 
    2827   IMPLICIT NONE 
     
    5756      !! 
    5857      CHARACTER(LEN=20)   ::   clkt     ! ocean time-step deine as a character 
    59       CHARACTER(LEN=50)   ::   clname   ! ice output restart file name 
     58      CHARACTER(LEN=50)   ::   clname   ! ocean output restart file name 
     59      CHARACTER(lc)       ::   clpath   ! full path to ocean output restart file 
    6060      !!---------------------------------------------------------------------- 
    6161      ! 
    6262      IF( kt == nit000 ) THEN   ! default definitions 
    6363         lrst_oce = .FALSE.    
    64          nitrst = nitend 
    65       ENDIF 
    66       IF( MOD( kt - 1, nstock ) == 0 ) THEN    
     64         IF( ln_rst_list ) THEN 
     65            nrst_lst = 1 
     66            nitrst = nstocklist( nrst_lst ) 
     67         ELSE 
     68            nitrst = nitend 
     69         ENDIF 
     70      ENDIF 
     71 
     72      ! frequency-based restart dumping (nn_stock) 
     73      IF( .NOT. ln_rst_list .AND. MOD( kt - 1, nstock ) == 0 ) THEN    
    6774         ! we use kt - 1 and not kt - nit000 to keep the same periodicity from the beginning of the experiment 
    6875         nitrst = kt + nstock - 1                  ! define the next value of nitrst for restart writing 
     
    7380      ! except if we write ocean restart files every time step or if an ocean restart file was writen at nitend - 1 
    7481      IF( kt == nitrst - 1 .OR. nstock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN 
    75          ! beware of the format used to write kt (default is i8.8, that should be large enough...) 
    76          IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst 
    77          ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst 
    78          ENDIF 
    79          ! create the file 
    80          clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_ocerst_out) 
    81          IF(lwp) THEN 
    82             WRITE(numout,*) 
    83             SELECT CASE ( jprstlib ) 
    84             CASE ( jprstdimg )   ;   WRITE(numout,*) '             open ocean restart binary file: '//clname 
    85             CASE DEFAULT         ;   WRITE(numout,*) '             open ocean restart NetCDF file: '//clname 
    86             END SELECT 
    87             IF ( snc4set%luse )      WRITE(numout,*) '             opened for NetCDF4 chunking and compression' 
    88             IF( kt == nitrst - 1 ) THEN   ;   WRITE(numout,*) '             kt = nitrst - 1 = ', kt 
    89             ELSE                          ;   WRITE(numout,*) '             kt = '             , kt 
     82         IF( nitrst <= nitend .AND. nitrst > 0 ) THEN  
     83            ! beware of the format used to write kt (default is i8.8, that should be large enough...) 
     84            IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst 
     85            ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst 
    9086            ENDIF 
    91          ENDIF 
    92          ! 
    93          CALL iom_open( clname, numrow, ldwrt = .TRUE., kiolib = jprstlib ) 
    94          lrst_oce = .TRUE. 
     87            ! create the file 
     88            clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_ocerst_out) 
     89            clpath = TRIM(cn_ocerst_outdir) 
     90            IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 
     91            IF(lwp) THEN 
     92               WRITE(numout,*) 
     93               SELECT CASE ( jprstlib ) 
     94               CASE ( jprstdimg )   ;   WRITE(numout,*)                            & 
     95                   '             open ocean restart binary file: ',TRIM(clpath)//clname 
     96               CASE DEFAULT         ;   WRITE(numout,*)                            & 
     97                   '             open ocean restart NetCDF file: ',TRIM(clpath)//clname 
     98               END SELECT 
     99               IF ( snc4set%luse )      WRITE(numout,*) '             opened for NetCDF4 chunking and compression' 
     100               IF( kt == nitrst - 1 ) THEN   ;   WRITE(numout,*) '             kt = nitrst - 1 = ', kt 
     101               ELSE                          ;   WRITE(numout,*) '             kt = '             , kt 
     102               ENDIF 
     103            ENDIF 
     104            ! 
     105            CALL iom_open( TRIM(clpath)//TRIM(clname), numrow, ldwrt = .TRUE., kiolib = jprstlib ) 
     106            lrst_oce = .TRUE. 
     107         ENDIF 
    95108      ENDIF 
    96109      ! 
     
    120133                     CALL iom_rstput( kt, nitrst, numrow, 'hdivb'  , hdivb     ) 
    121134                     CALL iom_rstput( kt, nitrst, numrow, 'sshb'   , sshb      ) 
    122       IF( lk_lim3 )  CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) ) 
    123                      ! 
    124       IF( lk_lim3 )  CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) ) 
    125135                     ! 
    126136                     CALL iom_rstput( kt, nitrst, numrow, 'un'     , un        )     ! now fields 
     
    135145                     CALL iom_rstput( kt, nitrst, numrow, 'rhd'    , rhd       ) 
    136146#endif 
    137                   IF( lk_lim3 ) THEN 
    138                      CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev'  , fraqsr_1lev     ) !clem modif 
    139                   ENDIF 
    140147      IF( kt == nitrst ) THEN 
    141148         CALL iom_close( numrow )     ! close the restart file (only at last time step) 
     
    143150!!gm  not sure what to do here   ===>>>  ask to Sebastian 
    144151         lrst_oce = .FALSE. 
     152            IF( ln_rst_list ) THEN 
     153               nrst_lst = MIN(nrst_lst + 1, SIZE(nstocklist,1)) 
     154               nitrst = nstocklist( nrst_lst ) 
     155            ENDIF 
     156            lrst_oce = .FALSE. 
    145157      ENDIF 
    146158      ! 
     
    157169      !!                the file has already been opened 
    158170      !!---------------------------------------------------------------------- 
    159       INTEGER  ::   jlibalt = jprstlib 
    160       LOGICAL  ::   llok 
     171      INTEGER        ::   jlibalt = jprstlib 
     172      LOGICAL        ::   llok 
     173      CHARACTER(lc)  ::   clpath   ! full path to ocean output restart file 
    161174      !!---------------------------------------------------------------------- 
    162175      ! 
     
    172185         ENDIF 
    173186 
     187         clpath = TRIM(cn_ocerst_indir) 
     188         IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 
    174189         IF ( jprstlib == jprstdimg ) THEN 
    175190           ! eventually read netcdf file (monobloc)  for restarting on different number of processors 
    176191           ! if {cn_ocerst_in}.nc exists, then set jlibalt to jpnf90 
    177            INQUIRE( FILE = TRIM(cn_ocerst_in)//'.nc', EXIST = llok ) 
     192           INQUIRE( FILE = TRIM(cn_ocerst_indir)//'/'//TRIM(cn_ocerst_in)//'.nc', EXIST = llok ) 
    178193           IF ( llok ) THEN ; jlibalt = jpnf90  ; ELSE ; jlibalt = jprstlib ; ENDIF 
    179194         ENDIF 
    180          CALL iom_open( cn_ocerst_in, numror, kiolib = jlibalt ) 
     195         CALL iom_open( TRIM(clpath)//cn_ocerst_in, numror, kiolib = jlibalt ) 
    181196      ENDIF 
    182197   END SUBROUTINE rst_read_open 
     
    215230         CALL iom_get( numror, jpdom_autoglo, 'hdivb'  , hdivb   ) 
    216231         CALL iom_get( numror, jpdom_autoglo, 'sshb'   , sshb    ) 
    217          IF( lk_lim3 )   CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) ) 
    218232      ELSE 
    219233         neuler = 0 
     
    258272         ENDIF 
    259273 
    260          IF( lk_lim3 .AND. .NOT. lk_vvl ) THEN 
    261             DO jk = 1, jpk 
    262                fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 
    263             END DO 
    264          ENDIF 
    265  
    266       ENDIF 
    267       ! 
    268       IF( lk_lim3 ) THEN 
    269          CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev' , fraqsr_1lev ) 
    270274      ENDIF 
    271275      ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r5038 r5620  
    2222   USE lib_mpp          ! distributed memory computing library 
    2323 
     24 
     25   INTERFACE lbc_lnk_multi 
     26      MODULE PROCEDURE mpp_lnk_2d_9 
     27   END INTERFACE 
     28 
    2429   INTERFACE lbc_lnk 
    2530      MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 
     
    3944 
    4045   PUBLIC lbc_lnk       ! ocean lateral boundary conditions 
     46   PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 
    4147   PUBLIC lbc_lnk_e 
    4248   PUBLIC lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r5038 r5620  
    7171   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    7272   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
     73   PUBLIC   mpp_lnk_2d_9  
    7374   PUBLIC   mppscatter, mppgather 
    7475   PUBLIC   mpp_ini_ice, mpp_ini_znl 
     
    7879   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
    7980 
     81   TYPE arrayptr 
     82      REAL , DIMENSION (:,:),  POINTER :: pt2d 
     83   END TYPE arrayptr 
     84    
    8085   !! * Interfaces 
    8186   !! define generic interface for these routine as they are called sometimes 
     
    164169 
    165170 
    166    FUNCTION mynode( ldtxt, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
     171   FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 
    167172      !!---------------------------------------------------------------------- 
    168173      !!                  ***  routine mynode  *** 
     
    171176      !!---------------------------------------------------------------------- 
    172177      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
     178      CHARACTER(len=*)             , INTENT(in   ) ::   ldname 
    173179      INTEGER                      , INTENT(in   ) ::   kumnam_ref     ! logical unit for reference namelist 
    174180      INTEGER                      , INTENT(in   ) ::   kumnam_cfg     ! logical unit for configuration namelist 
     
    297303 
    298304      IF( mynode == 0 ) THEN 
    299         CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    300         WRITE(kumond, nammpp)       
     305         CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
     306         WRITE(kumond, nammpp)       
    301307      ENDIF 
    302308      ! 
     
    510516      ! 
    511517   END SUBROUTINE mpp_lnk_3d 
     518 
     519   SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 
     520      !!---------------------------------------------------------------------- 
     521      !!                  ***  routine mpp_lnk_2d_multiple  *** 
     522      !! 
     523      !! ** Purpose :   Message passing management for multiple 2d arrays 
     524      !! 
     525      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     526      !!      between processors following neighboring subdomains. 
     527      !!            domain parameters 
     528      !!                    nlci   : first dimension of the local subdomain 
     529      !!                    nlcj   : second dimension of the local subdomain 
     530      !!                    nbondi : mark for "east-west local boundary" 
     531      !!                    nbondj : mark for "north-south local boundary" 
     532      !!                    noea   : number for local neighboring processors 
     533      !!                    nowe   : number for local neighboring processors 
     534      !!                    noso   : number for local neighboring processors 
     535      !!                    nono   : number for local neighboring processors 
     536      !! 
     537      !!---------------------------------------------------------------------- 
     538 
     539      INTEGER :: num_fields 
     540      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     541      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     542      !                                                               ! = T , U , V , F , W and I points 
     543      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     544      !                                                               ! =  1. , the sign is kept 
     545      CHARACTER(len=3), OPTIONAL    , INTENT(in   ) ::   cd_mpp       ! fill the overlap area only 
     546      REAL(wp)        , OPTIONAL    , INTENT(in   ) ::   pval         ! background value (used at closed boundaries) 
     547      !! 
     548      INTEGER  ::   ji, jj, jl   ! dummy loop indices 
     549      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     550      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     551      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     552 
     553      REAL(wp) ::   zland 
     554      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     555      ! 
     556      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
     557      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
     558 
     559      !!---------------------------------------------------------------------- 
     560 
     561      ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields),  & 
     562         &      zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields)   ) 
     563 
     564      ! 
     565      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     566      ELSE                         ;   zland = 0.e0      ! zero by default 
     567      ENDIF 
     568 
     569      ! 1. standard boundary treatment 
     570      ! ------------------------------ 
     571      ! 
     572      !First Array 
     573      DO ii = 1 , num_fields 
     574         IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
     575            ! 
     576            ! WARNING pt2d is defined only between nld and nle 
     577            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
     578               pt2d_array(ii)%pt2d(nldi  :nlei  , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 
     579               pt2d_array(ii)%pt2d(1     :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi     , nlej) 
     580               pt2d_array(ii)%pt2d(nlei+1:nlci  , jj) = pt2d_array(ii)%pt2d(     nlei, nlej)  
     581            END DO 
     582            DO ji = nlci+1, jpi                 ! added column(s) (full) 
     583               pt2d_array(ii)%pt2d(ji, nldj  :nlej  ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 
     584               pt2d_array(ii)%pt2d(ji, 1     :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj     ) 
     585               pt2d_array(ii)%pt2d(ji, nlej+1:jpj   ) = pt2d_array(ii)%pt2d(nlei,      nlej) 
     586            END DO 
     587            ! 
     588         ELSE                              ! standard close or cyclic treatment 
     589            ! 
     590            !                                   ! East-West boundaries 
     591            IF( nbondi == 2 .AND.   &                ! Cyclic east-west 
     592               &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
     593               pt2d_array(ii)%pt2d(  1  , : ) = pt2d_array(ii)%pt2d( jpim1, : )                                    ! west 
     594               pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d(   2  , : )                                    ! east 
     595            ELSE                                     ! closed 
     596               IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(            1 : jpreci,:) = zland    ! south except F-point 
     597                                                   pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi   ,:) = zland    ! north 
     598            ENDIF 
     599            !                                   ! North-South boundaries (always closed) 
     600               IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(:,             1:jprecj ) = zland    ! south except F-point 
     601                                                   pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj    ) = zland    ! north 
     602            ! 
     603         ENDIF 
     604      END DO 
     605 
     606      ! 2. East and west directions exchange 
     607      ! ------------------------------------ 
     608      ! we play with the neigbours AND the row number because of the periodicity 
     609      ! 
     610      DO ii = 1 , num_fields 
     611         SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     612         CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     613            iihom = nlci-nreci 
     614            DO jl = 1, jpreci 
     615               zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 
     616               zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 
     617            END DO 
     618         END SELECT 
     619      END DO 
     620      ! 
     621      !                           ! Migrations 
     622      imigr = jpreci * jpj 
     623      ! 
     624      SELECT CASE ( nbondi ) 
     625      CASE ( -1 ) 
     626         CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 
     627         CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 
     628         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     629      CASE ( 0 ) 
     630         CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 
     631         CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 
     632         CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 
     633         CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 
     634         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     635         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     636      CASE ( 1 ) 
     637         CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 
     638         CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 
     639         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     640      END SELECT 
     641      ! 
     642      !                           ! Write Dirichlet lateral conditions 
     643      iihom = nlci - jpreci 
     644      ! 
     645 
     646      DO ii = 1 , num_fields 
     647         SELECT CASE ( nbondi ) 
     648         CASE ( -1 ) 
     649            DO jl = 1, jpreci 
     650               pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 
     651            END DO 
     652         CASE ( 0 ) 
     653            DO jl = 1, jpreci 
     654               pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 
     655               pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 
     656            END DO 
     657         CASE ( 1 ) 
     658            DO jl = 1, jpreci 
     659               pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 
     660            END DO 
     661         END SELECT 
     662      END DO 
     663       
     664      ! 3. North and south directions 
     665      ! ----------------------------- 
     666      ! always closed : we play only with the neigbours 
     667      ! 
     668      !First Array 
     669      DO ii = 1 , num_fields 
     670         IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     671            ijhom = nlcj-nrecj 
     672            DO jl = 1, jprecj 
     673               zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 
     674               zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 
     675            END DO 
     676         ENDIF 
     677      END DO 
     678      ! 
     679      !                           ! Migrations 
     680      imigr = jprecj * jpi 
     681      ! 
     682      SELECT CASE ( nbondj ) 
     683      CASE ( -1 ) 
     684         CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 
     685         CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 
     686         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     687      CASE ( 0 ) 
     688         CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 
     689         CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 
     690         CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 
     691         CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 
     692         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     693         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     694      CASE ( 1 ) 
     695         CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 
     696         CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 
     697         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     698      END SELECT 
     699      ! 
     700      !                           ! Write Dirichlet lateral conditions 
     701      ijhom = nlcj - jprecj 
     702      ! 
     703 
     704      DO ii = 1 , num_fields 
     705         !First Array 
     706         SELECT CASE ( nbondj ) 
     707         CASE ( -1 ) 
     708            DO jl = 1, jprecj 
     709               pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 
     710            END DO 
     711         CASE ( 0 ) 
     712            DO jl = 1, jprecj 
     713               pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 
     714               pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 
     715            END DO 
     716         CASE ( 1 ) 
     717            DO jl = 1, jprecj 
     718               pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 
     719            END DO 
     720         END SELECT 
     721      END DO 
     722       
     723      ! 4. north fold treatment 
     724      ! ----------------------- 
     725      ! 
     726      DO ii = 1 , num_fields 
     727         !First Array 
     728         IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     729            ! 
     730            SELECT CASE ( jpni ) 
     731            CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     732            CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
     733            END SELECT 
     734            ! 
     735         ENDIF 
     736         ! 
     737      END DO 
     738       
     739      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
     740      ! 
     741   END SUBROUTINE mpp_lnk_2d_multiple 
     742 
     743    
     744   SUBROUTINE load_array(pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields) 
     745      !!--------------------------------------------------------------------- 
     746      REAL(wp), DIMENSION(jpi,jpj), TARGET   ,   INTENT(inout) ::   pt2d    ! Second 2D array on which the boundary condition is applied 
     747      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type ! define the nature of ptab array grid-points 
     748      REAL(wp)                    , INTENT(in   ) ::   psgn    ! =-1 the sign change across the north fold boundary 
     749      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array 
     750      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
     751      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
     752      INTEGER                      , INTENT (inout):: num_fields  
     753      !!--------------------------------------------------------------------- 
     754      num_fields=num_fields+1 
     755      pt2d_array(num_fields)%pt2d=>pt2d 
     756      type_array(num_fields)=cd_type 
     757      psgn_array(num_fields)=psgn 
     758   END SUBROUTINE load_array 
     759    
     760    
     761   SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     762      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     763      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     764      !!--------------------------------------------------------------------- 
     765      ! Second 2D array on which the boundary condition is applied 
     766      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA     
     767      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     768      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI  
     769      ! define the nature of ptab array grid-points 
     770      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     771      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     772      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     773      ! =-1 the sign change across the north fold boundary 
     774      REAL(wp)                                      , INTENT(in   ) ::   psgnA     
     775      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     776      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI    
     777      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     778      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     779      !! 
     780      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array  
     781      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points 
     782      !                                                         ! = T , U , V , F , W and I points 
     783      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary 
     784      INTEGER :: num_fields 
     785      !!--------------------------------------------------------------------- 
     786 
     787      num_fields = 0 
     788 
     789      !! Load the first array 
     790      CALL load_array(pt2dA,cd_typeA,psgnA,pt2d_array, type_array, psgn_array,num_fields) 
     791 
     792      !! Look if more arrays are added 
     793      IF(PRESENT (psgnB) )CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 
     794      IF(PRESENT (psgnC) )CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 
     795      IF(PRESENT (psgnD) )CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 
     796      IF(PRESENT (psgnE) )CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 
     797      IF(PRESENT (psgnF) )CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 
     798      IF(PRESENT (psgnG) )CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 
     799      IF(PRESENT (psgnH) )CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 
     800      IF(PRESENT (psgnI) )CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 
     801       
     802      CALL mpp_lnk_2d_multiple(pt2d_array,type_array,psgn_array,num_fields,cd_mpp,pval) 
     803   END SUBROUTINE mpp_lnk_2d_9 
    512804 
    513805 
     
    31843476   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 
    31853477   INTEGER :: ncomm_ice 
     3478   INTEGER, PUBLIC            ::   mpi_comm_opa          ! opa local communicator 
    31863479   !!---------------------------------------------------------------------- 
    31873480CONTAINS 
     
    31923485   END FUNCTION lib_mpp_alloc 
    31933486 
    3194    FUNCTION mynode( ldtxt, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value) 
     3487   FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value) 
    31953488      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    31963489      CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
     3490      CHARACTER(len=*) ::   ldname 
    31973491      INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop 
    3198       IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0 
     3492      IF( PRESENT( localComm ) ) mpi_comm_opa = localComm 
     3493      function_value = 0 
    31993494      IF( .FALSE. )   ldtxt(:) = 'never done' 
    3200       CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
     3495      CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    32013496   END FUNCTION mynode 
    32023497 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r5038 r5620  
    4545      INTEGER ::  inum                        ! temporary logical unit 
    4646      INTEGER ::  idir                        ! temporary integers 
     47      INTEGER ::  jstartrow                   ! temporary integers 
    4748      INTEGER ::   ios                        ! Local integer output status for namelist read 
    4849      INTEGER ::   & 
     
    100101      ! open the file 
    101102      ! Remember that at this level in the code, mpp is not yet initialized, so 
    102       ! the file must be open with jpdom_unknown, and kstart amd kcount forced  
     103      ! the file must be open with jpdom_unknown, and kstart and kcount forced  
     104      jstartrow = 1 
    103105      IF ( ln_zco ) THEN  
    104106         CALL iom_open ( 'bathy_level.nc', inum )   ! Level bathymetry 
    105          CALL iom_get ( inum, jpdom_unknown, 'Bathy_level', zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) 
     107          ! Optionally use a file attribute (open_ocean_jstart) to set a start row for reading from the global file 
     108          ! This allows the unextended grid bathymetry to be stored in the same file as the under ice-shelf extended bathymetry 
     109         CALL iom_getatt(inum, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 
     110         jstartrow = MAX(1,jstartrow) 
     111         CALL iom_get ( inum, jpdom_unknown, 'Bathy_level', zdta, kstart=(/jpizoom,jpjzoom+jstartrow-1/), kcount=(/jpiglo,jpjglo/) ) 
    106112      ELSE 
    107113         CALL iom_open ( 'bathy_meter.nc', inum )   ! Meter bathy in case of partial steps 
    108          CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) 
     114         IF ( ln_isfcav ) THEN 
     115             CALL iom_get ( inum, jpdom_unknown, 'Bathymetry_isf' , zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) 
     116         ELSE 
     117             ! Optionally use a file attribute (open_ocean_jstart) to set a start row for reading from the global file 
     118             ! This allows the unextended grid bathymetry to be stored in the same file as the under ice-shelf extended bathymetry 
     119             CALL iom_getatt(inum, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 
     120             jstartrow = MAX(1,jstartrow) 
     121             CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , zdta, kstart=(/jpizoom,jpjzoom+jstartrow-1/)   & 
     122                &                                                   , kcount=(/jpiglo,jpjglo/) ) 
     123         ENDIF 
    109124      ENDIF 
    110125      CALL iom_close (inum) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c2d.h90

    r4325 r5620  
    140140      !!---------------------------------------------------------------------- 
    141141      USE ldftra_oce, ONLY:   aht0 
     142      USE iom 
    142143      ! 
    143144      LOGICAL, INTENT (in) ::   ld_print   ! If true, output arrays on numout 
     
    146147      INTEGER  ::   inum, iim, ijm            ! local integers 
    147148      INTEGER  ::   ifreq, il1, il2, ij, ii 
    148       INTEGER  ::   ijpt0,ijpt1 
     149      INTEGER  ::   ijpt0,ijpt1, ierror 
    149150      REAL(wp) ::   zahmeq, zcoft, zcoff, zmsk 
    150151      CHARACTER (len=15) ::   clexp 
    151       INTEGER, POINTER, DIMENSION(:,:)  :: icof 
    152       INTEGER, POINTER, DIMENSION(:,:)  :: idata 
     152      INTEGER,     POINTER, DIMENSION(:,:)  :: icof 
     153      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztemp2d  ! temporary array to read ahmcoef file 
    153154      !!---------------------------------------------------------------------- 
    154155      !                                 
    155156      CALL wrk_alloc( jpi   , jpj   , icof  ) 
    156       CALL wrk_alloc( jpidta, jpjdta, idata ) 
    157157      ! 
    158158      IF(lwp) WRITE(numout,*) 
     
    233233         ! Read 2d integer array to specify western boundary increase in the 
    234234         ! ===================== equatorial strip (20N-20S) defined at t-points 
    235           
    236          CALL ctl_opn( inum, 'ahmcoef', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
    237          READ(inum,9101) clexp, iim, ijm 
    238          READ(inum,'(/)') 
    239          ifreq = 40 
    240          il1 = 1 
    241          DO jn = 1, jpidta/ifreq+1 
    242             READ(inum,'(/)') 
    243             il2 = MIN( jpidta, il1+ifreq-1 ) 
    244             READ(inum,9201) ( ii, ji = il1, il2, 5 ) 
    245             READ(inum,'(/)') 
    246             DO jj = jpjdta, 1, -1 
    247                READ(inum,9202) ij, ( idata(ji,jj), ji = il1, il2 ) 
    248             END DO 
    249             il1 = il1 + ifreq 
    250          END DO 
    251  
    252          DO jj = 1, nlcj 
    253             DO ji = 1, nlci 
    254                icof(ji,jj) = idata( mig(ji), mjg(jj) ) 
    255             END DO 
    256          END DO 
    257          DO jj = nlcj+1, jpj 
    258             DO ji = 1, nlci 
    259                icof(ji,jj) = icof(ji,nlcj) 
    260             END DO 
    261          END DO 
    262          DO jj = 1, jpj 
    263             DO ji = nlci+1, jpi 
    264                icof(ji,jj) = icof(nlci,jj) 
    265             END DO 
    266          END DO 
    267  
    268 9101     FORMAT(1x,a15,2i8) 
    269 9201     FORMAT(3x,13(i3,12x)) 
    270 9202     FORMAT(i3,41i3) 
    271  
     235         ! 
     236         ALLOCATE( ztemp2d(jpi,jpj) ) 
     237         ztemp2d(:,:) = 0. 
     238         CALL iom_open ( 'ahmcoef.nc', inum ) 
     239         CALL iom_get  ( inum, jpdom_data, 'icof', ztemp2d) 
     240         icof(:,:)  = NINT(ztemp2d(:,:)) 
     241         CALL iom_close( inum ) 
     242         DEALLOCATE(ztemp2d) 
    272243 
    273244         ! Set ahm1 and ahm2  ( T- and F- points) (used for laplacian operator) 
     
    346317      ! 
    347318      CALL wrk_dealloc( jpi   , jpj   , icof  ) 
    348       CALL wrk_dealloc( jpidta, jpjdta, idata ) 
    349319      ! 
    350320   END SUBROUTINE ldf_dyn_c2d_orca 
     
    367337      !!---------------------------------------------------------------------- 
    368338      USE ldftra_oce, ONLY:   aht0 
     339      USE iom 
    369340      ! 
    370341      LOGICAL, INTENT (in) ::   ld_print   ! If true, output arrays on numout 
     
    374345      INTEGER ::   iim, ijm 
    375346      INTEGER ::   ifreq, il1, il2, ij, ii 
    376       INTEGER ::   ijpt0,ijpt1 
     347      INTEGER ::   ijpt0,ijpt1, ierror 
    377348      REAL(wp) ::   zahmeq, zcoft, zcoff, zmsk, zam20s 
    378349      CHARACTER (len=15) ::   clexp 
    379       INTEGER, POINTER, DIMENSION(:,:)  :: icof 
    380       INTEGER, POINTER, DIMENSION(:,:)  :: idata 
     350      INTEGER,     POINTER, DIMENSION(:,:)  :: icof 
     351      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztemp2d  ! temporary array to read ahmcoef file 
    381352      !!---------------------------------------------------------------------- 
    382353      !                                 
    383354      CALL wrk_alloc( jpi   , jpj   , icof  ) 
    384       CALL wrk_alloc( jpidta, jpjdta, idata ) 
    385355      !                                 
    386  
    387356      IF(lwp) WRITE(numout,*) 
    388357      IF(lwp) WRITE(numout,*) 'inildf: 2d eddy viscosity coefficient' 
     
    463432         ! Read 2d integer array to specify western boundary increase in the 
    464433         ! ===================== equatorial strip (20N-20S) defined at t-points 
    465           
    466          CALL ctl_opn( inum, 'ahmcoef', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL',   & 
    467             &           1, numout, lwp ) 
    468          REWIND inum 
    469          READ(inum,9101) clexp, iim, ijm 
    470          READ(inum,'(/)') 
    471          ifreq = 40 
    472          il1 = 1 
    473          DO jn = 1, jpidta/ifreq+1 
    474             READ(inum,'(/)') 
    475             il2 = MIN( jpidta, il1+ifreq-1 ) 
    476             READ(inum,9201) ( ii, ji = il1, il2, 5 ) 
    477             READ(inum,'(/)') 
    478             DO jj = jpjdta, 1, -1 
    479                READ(inum,9202) ij, ( idata(ji,jj), ji = il1, il2 ) 
    480             END DO 
    481             il1 = il1 + ifreq 
    482          END DO 
    483  
    484          DO jj = 1, nlcj 
    485             DO ji = 1, nlci 
    486                icof(ji,jj) = idata( mig(ji), mjg(jj) ) 
    487             END DO 
    488          END DO 
    489          DO jj = nlcj+1, jpj 
    490             DO ji = 1, nlci 
    491                icof(ji,jj) = icof(ji,nlcj) 
    492             END DO 
    493          END DO 
    494          DO jj = 1, jpj 
    495             DO ji = nlci+1, jpi 
    496                icof(ji,jj) = icof(nlci,jj) 
    497             END DO 
    498          END DO 
    499  
    500 9101     FORMAT(1x,a15,2i8) 
    501 9201     FORMAT(3x,13(i3,12x)) 
    502 9202     FORMAT(i3,41i3) 
    503  
     434         ALLOCATE( ztemp2d(jpi,jpj) ) 
     435         ztemp2d(:,:) = 0. 
     436         CALL iom_open ( 'ahmcoef.nc', inum ) 
     437         CALL iom_get  ( inum, jpdom_data, 'icof', ztemp2d) 
     438         icof(:,:)  = NINT(ztemp2d(:,:)) 
     439         CALL iom_close( inum ) 
     440         DEALLOCATE(ztemp2d) 
    504441 
    505442         ! Set ahm1 and ahm2  ( T- and F- points) (used for laplacian operator) 
     
    583520      ! 
    584521      CALL wrk_dealloc( jpi   , jpj   , icof  ) 
    585       CALL wrk_dealloc( jpidta, jpjdta, idata ) 
    586522      ! 
    587523   END SUBROUTINE ldf_dyn_c2d_orca_R1 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c3d.h90

    r4292 r5620  
    2727      !!---------------------------------------------------------------------- 
    2828      USE ldftra_oce, ONLY :   aht0 
     29      USE iom 
    2930      !! 
    3031      LOGICAL, INTENT (in) ::   ld_print   ! If true, output arrays on numout 
     
    193194      !!---------------------------------------------------------------------- 
    194195      USE ldftra_oce, ONLY:   aht0 
     196      USE iom 
    195197      !! 
    196198      LOGICAL, INTENT(in) ::   ld_print   ! If true, output arrays on numout 
     
    204206      CHARACTER (len=15) ::   clexp 
    205207      INTEGER , POINTER, DIMENSION(:,:)  :: icof 
    206       INTEGER , POINTER, DIMENSION(:,:)  :: idata 
    207208      REAL(wp), POINTER, DIMENSION(:  )  :: zcoef    
    208209      REAL(wp), POINTER, DIMENSION(:,:)  :: zahm0 
     210      ! 
     211      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   ztemp2d  ! temporary array to read ahmcoef file 
    209212      !!---------------------------------------------------------------------- 
    210213      ! 
    211214      CALL wrk_alloc( jpi   , jpj   , icof  ) 
    212       CALL wrk_alloc( jpidta, jpjdta, idata ) 
    213215      CALL wrk_alloc( jpk   ,         zcoef ) 
    214216      CALL wrk_alloc( jpi   , jpj   , zahm0 ) 
     
    221223      ! Read 2d integer array to specify western boundary increase in the 
    222224      ! ===================== equatorial strip (20N-20S) defined at t-points 
    223  
    224       CALL ctl_opn( inum, 'ahmcoef', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
    225       READ(inum,9101) clexp, iim, ijm 
    226       READ(inum,'(/)') 
    227       ifreq = 40 
    228       il1 = 1 
    229       DO jn = 1, jpidta/ifreq+1 
    230          READ(inum,'(/)') 
    231          il2 = MIN( jpidta, il1+ifreq-1 ) 
    232          READ(inum,9201) ( ii, ji = il1, il2, 5 ) 
    233          READ(inum,'(/)') 
    234          DO jj = jpjdta, 1, -1 
    235             READ(inum,9202) ij, ( idata(ji,jj), ji = il1, il2 ) 
    236          END DO 
    237          il1 = il1 + ifreq 
    238       END DO 
    239        
    240       DO jj = 1, nlcj 
    241          DO ji = 1, nlci 
    242             icof(ji,jj) = idata( mig(ji), mjg(jj) ) 
    243          END DO 
    244       END DO 
    245       DO jj = nlcj+1, jpj 
    246          DO ji = 1, nlci 
    247             icof(ji,jj) = icof(ji,nlcj) 
    248          END DO 
    249       END DO 
    250       DO jj = 1, jpj 
    251          DO ji = nlci+1, jpi 
    252             icof(ji,jj) = icof(nlci,jj) 
    253          END DO 
    254       END DO 
    255        
    256 9101  FORMAT(1x,a15,2i8) 
    257 9201  FORMAT(3x,13(i3,12x)) 
    258 9202  FORMAT(i3,41i3) 
    259        
     225      ALLOCATE( ztemp2d(jpi,jpj) ) 
     226      ztemp2d(:,:) = 0. 
     227      CALL iom_open ( 'ahmcoef.nc', inum ) 
     228      CALL iom_get  ( inum, jpdom_data, 'icof', ztemp2d) 
     229      icof(:,:)  = NINT(ztemp2d(:,:)) 
     230      CALL iom_close( inum ) 
     231      DEALLOCATE(ztemp2d) 
     232 
    260233      ! Set ahm1 and ahm2 
    261234      ! ================= 
     
    455428      ! 
    456429      CALL wrk_dealloc( jpi   , jpj   , icof  ) 
    457       CALL wrk_dealloc( jpidta, jpjdta, idata ) 
    458430      CALL wrk_dealloc( jpk   ,         zcoef ) 
    459431      CALL wrk_dealloc( jpi   , jpj   , zahm0 ) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_smag.F90

    • Property svn:keywords set to Id
    r3634 r5620  
    3131   !!---------------------------------------------------------------------- 
    3232   !!  OPA 9.0 , LOCEAN-IPSL (2005)  
    33    !! $Id: ldf_tra_smag.F90 1482 2010-06-13 15:28:06Z  $ 
     33   !! $Id$ 
    3434   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    3535   !!---------------------------------------------------------------------- 
     
    5151   !!---------------------------------------------------------------------- 
    5252   !!  OPA 9.0 , LOCEAN-IPSL (2005)  
    53    !! $Id: ldfdyn_c3d.h90 1581 2009-08-05 14:53:12Z smasson $  
     53   !! $Id$  
    5454   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5555   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r5038 r5620  
    142142            DO jj = 1, jpjm1 
    143143               DO ji = 1, jpim1 
    144 ! IF should be useless check zpshde (PM) 
    145                IF ( mbku(ji,jj) > 1 ) zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) 
    146                IF ( mbkv(ji,jj) > 1 ) zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) 
     144                  zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) 
     145                  zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) 
     146               END DO 
     147            END DO 
     148         ENDIF 
     149         IF( ln_zps .AND. ln_isfcav ) THEN           ! partial steps correction at the bottom ocean level 
     150            DO jj = 1, jpjm1 
     151               DO ji = 1, jpim1 
    147152               IF ( miku(ji,jj) > 1 ) zgru(ji,jj,miku(ji,jj)) = grui(ji,jj)  
    148153               IF ( mikv(ji,jj) > 1 ) zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj) 
     
    151156         ENDIF 
    152157         ! 
    153          zdzr(:,:,1) = 0._wp        !==   Local vertical density gradient at T-point   == !   (evaluated from N^2) 
    154          DO jk = 1, jpkm1 
     158         !==   Local vertical density gradient at T-point   == !   (evaluated from N^2) 
     159         ! interior value 
     160         DO jk = 2, jpkm1 
    155161            !                                ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point 
    156162            !                                !   trick: tmask(ik  )  = 0   =>   all pn2   = 0   =>   zdzr = 0 
     
    162168         END DO 
    163169         ! surface initialisation  
    164          DO jj = 1, jpjm1 
    165             DO ji = 1, jpim1 
    166               zdzr(ji,jj,1:mikt(ji,jj)) = 0._wp 
    167             END DO 
    168          END DO 
     170         zdzr(:,:,1) = 0._wp  
     171         IF ( ln_isfcav ) THEN 
     172            ! if isf need to overwrite the interior value at at the first ocean point 
     173            DO jj = 1, jpjm1 
     174               DO ji = 1, jpim1 
     175                  zdzr(ji,jj,1:mikt(ji,jj)) = 0._wp 
     176               END DO 
     177            END DO 
     178         END IF 
    169179         ! 
    170180         !                          !==   Slopes just below the mixed layer   ==! 
     
    175185         ! ===========================      | vslp = d/dj( prd ) / d/dz( prd ) 
    176186         ! 
    177          DO jj = 2, jpjm1 
    178             DO ji = fs_2, fs_jpim1   ! vector opt. 
    179                IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = hmlpt(ji  ,jj) 
    180                IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = hmlpt(ji+1,jj) 
    181                IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj), hmlpt(ji+1,jj)) 
    182                IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = hmlpt(ji  ,jj) 
    183                IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = hmlpt(ji,jj+1) 
    184                IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji,jj+1)) 
     187         IF ( ln_isfcav ) THEN 
     188            DO jj = 2, jpjm1 
     189               DO ji = fs_2, fs_jpim1   ! vector opt. 
     190                  IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
     191                  IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji+1,jj  ),                   5._wp) 
     192                  IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji+1,jj  ), 5._wp) 
     193                  IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
     194                  IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj+1),                   5._wp) 
     195                  IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji  ,jj+1), 5._wp) 
     196               ENDDO 
    185197            ENDDO 
    186          ENDDO 
     198         ELSE 
     199            DO jj = 2, jpjm1 
     200               DO ji = fs_2, fs_jpim1   ! vector opt. 
     201                  zhmlpu(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji+1,jj  ), 5._wp) 
     202                  zhmlpv(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji  ,jj+1), 5._wp) 
     203               ENDDO 
     204            ENDDO 
     205         END IF 
    187206         DO jk = 2, jpkm1                            !* Slopes at u and v points 
    188207            DO jj = 2, jpjm1 
     
    198217                  zbv = MIN(  zbv, -100._wp* ABS( zav ) , -7.e+3_wp/fse3v(ji,jj,jk)* ABS( zav )  ) 
    199218                  !                                      ! uslp and vslp output in zwz and zww, resp. 
    200                   zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) )  
    201                   zfj = MAX( omlmask(ji,jj,jk), omlmask(ji,jj+1,jk) )  
     219                  zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj  ,jk) ) 
     220                  zfj = MAX( omlmask(ji,jj,jk), omlmask(ji  ,jj+1,jk) ) 
    202221                  ! thickness of water column between surface and level k at u/v point 
    203                   zdepu = 0.5_wp * (( fsdept(ji,jj,jk) + fsdept(ji+1,jj  ,jk) )                   & 
    204                              - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj  ) )  & 
    205                              - fse3u(ji,jj,miku(ji,jj))                                         ) 
    206                   zdepv = 0.5_wp * (( fsdept(ji,jj,jk) + fsdept(ji  ,jj+1,jk) )                   & 
    207                              - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) & 
    208                              - fse3v(ji,jj,mikv(ji,jj))                                         ) 
    209                   zwz(ji,jj,jk) = ( 1. - zfi) * zau / ( zbu - zeps )                                              & 
    210                      &                 + zfi  * uslpml(ji,jj)                                                     & 
    211                      &                        * zdepu / MAX( zhmlpu(ji,jj), 5._wp ) 
    212                   zwz(ji,jj,jk) = zwz(ji,jj,jk) * umask(ji,jj,jk) * umask(ji,jj,jk-1) 
    213                   zww(ji,jj,jk) = ( 1. - zfj) * zav / ( zbv - zeps )                                              & 
    214                      &                 + zfj  * vslpml(ji,jj)                                                     & 
    215                      &                        * zdepv / MAX( zhmlpv(ji,jj), 5._wp )  
    216                   zww(ji,jj,jk) = zww(ji,jj,jk) * vmask(ji,jj,jk) * vmask(ji,jj,jk-1) 
     222                  zdepu = 0.5_wp * ( ( fsdept(ji,jj,jk) + fsdept(ji+1,jj  ,jk) )                              & 
     223                                   - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj  ) ) - fse3u(ji,jj,miku(ji,jj)) ) 
     224                  zdepv = 0.5_wp * ( ( fsdept(ji,jj,jk) + fsdept(ji  ,jj+1,jk) )                              & 
     225                                   - 2 * MAX( risfdep(ji,jj), risfdep(ji  ,jj+1) ) - fse3v(ji,jj,mikv(ji,jj)) ) 
     226                  ! 
     227                  zwz(ji,jj,jk) = ( 1. - zfi) * zau / ( zbu - zeps )                                          & 
     228                     &                 + zfi  * uslpml(ji,jj) * zdepu / zhmlpu(ji,jj) 
     229                  zwz(ji,jj,jk) = zwz(ji,jj,jk) * wumask(ji,jj,jk) 
     230                  zww(ji,jj,jk) = ( 1. - zfj) * zav / ( zbv - zeps )                                          & 
     231                     &                 + zfj  * vslpml(ji,jj) * zdepv / zhmlpv(ji,jj)  
     232                  zww(ji,jj,jk) = zww(ji,jj,jk) * wvmask(ji,jj,jk) 
    217233                   
    218234                  
     
    266282                  uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk  ) ) * 0.5_wp   & 
    267283                     &                            * ( umask(ji,jj  ,jk) + umask(ji,jj  ,jk+1) ) * 0.5_wp   & 
    268                      &                            *   umask(ji,jj,jk-1) !* umask(ji,jj,jk) * umask(ji,jj,jk+1) 
     284                     &                            *   umask(ji,jj,jk-1) 
    269285                  vslp(ji,jj,jk) = vslp(ji,jj,jk) * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk  ) ) * 0.5_wp   & 
    270286                     &                            * ( vmask(ji  ,jj,jk) + vmask(ji  ,jj,jk+1) ) * 0.5_wp   & 
    271                      &                            *   vmask(ji,jj,jk-1) !* vmask(ji,jj,jk) * vmask(ji,jj,jk+1) 
     287                     &                            *   vmask(ji,jj,jk-1) 
    272288               END DO 
    273289            END DO 
     
    282298               DO ji = fs_2, fs_jpim1   ! vector opt. 
    283299                  !                                  !* Local vertical density gradient evaluated from N^2 
    284                   zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 
     300                  zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) * wmask(ji,jj,jk) 
    285301                  !                                  !* Slopes at w point 
    286302                  !                                        ! i- & j-gradient of density at w-points 
     
    298314                  zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w(ji,jj,jk)* ABS( zaj )  ) 
    299315                  !                                        ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.) 
    300                   zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) )    ! zfk=1 in the ML otherwise zfk=0 
     316                  zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) )   ! zfk=1 in the ML otherwise zfk=0 
    301317                  zck = ( fsdepw(ji,jj,jk) - fsdepw(ji,jj,mikt(ji,jj) ) ) / MAX( hmlp(ji,jj), 10._wp ) 
    302318                  zwz(ji,jj,jk) = (  zai / ( zbi - zeps ) * ( 1._wp - zfk ) & 
    303                      &            + zck * wslpiml(ji,jj) * zfk  ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 
     319                     &            + zck * wslpiml(ji,jj) * zfk  ) * wmask(ji,jj,jk) 
    304320                  zww(ji,jj,jk) = (  zaj / ( zbj - zeps ) * ( 1._wp - zfk ) & 
    305                      &            + zck * wslpjml(ji,jj) * zfk  ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 
     321                     &            + zck * wslpjml(ji,jj) * zfk  ) * wmask(ji,jj,jk) 
    306322 
    307323!!gm  modif to suppress omlmask....  (as in Griffies operator) 
     
    356372                  zck =   ( umask(ji,jj,jk) + umask(ji-1,jj,jk) )   & 
    357373                     &  * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25 
    358                   wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck * tmask(ji,jj,jk-1) * tmask(ji,jj,jk) 
    359                   wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck * tmask(ji,jj,jk-1) * tmask(ji,jj,jk) 
     374                  wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck * wmask(ji,jj,jk) 
     375                  wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck * wmask(ji,jj,jk) 
    360376               END DO 
    361377            END DO 
     
    423439                  vslp(ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept_b(ji,jj+1,jk) - fsdept_b(ji ,jj ,jk) ) * vmask(ji,jj,jk)  
    424440                  wslpi(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw_b(ji+1,jj,jk) - fsdepw_b(ji-1,jj,jk) ) & 
    425                     &                              * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * 0.5  
     441                    &                              * wmask(ji,jj,jk) * 0.5  
    426442                  wslpj(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw_b(ji,jj+1,jk) - fsdepw_b(ji,jj-1,jk) ) & 
    427                     &                              * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * 0.5  
     443                    &                              * wmask(ji,jj,jk) * 0.5  
    428444               END DO  
    429445            END DO  
     
    736752            DO ji = 1, jpi 
    737753               ik = nmln(ji,jj) - 1 
    738                IF( jk <= ik .AND. jk >= mikt(ji,jj) ) THEN   ;   omlmask(ji,jj,jk) = 1._wp 
    739                ELSE                  ;   omlmask(ji,jj,jk) = 0._wp 
     754               IF( jk <= ik .AND. jk >= mikt(ji,jj) ) THEN 
     755                  omlmask(ji,jj,jk) = 1._wp 
     756               ELSE 
     757                  omlmask(ji,jj,jk) = 0._wp 
    740758               ENDIF 
    741759            END DO 
     
    794812            zbj = MIN(  zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w(ji,jj,ik)* ABS( zaj )  ) 
    795813            !                        !- i- & j-slope at w-points (wslpiml, wslpjml) 
    796             wslpiml(ji,jj) = zai / ( zbi - zeps ) * tmask (ji,jj,ik) 
    797             wslpjml(ji,jj) = zaj / ( zbj - zeps ) * tmask (ji,jj,ik) 
     814            wslpiml(ji,jj) = zai / ( zbi - zeps ) * wmask (ji,jj,ik) 
     815            wslpjml(ji,jj) = zaj / ( zbj - zeps ) * wmask (ji,jj,ik) 
    798816         END DO 
    799817      END DO 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_smag.F90

    • Property svn:keywords set to Id
    r3634 r5620  
    3131   !!---------------------------------------------------------------------- 
    3232   !!  OPA 9.0 , LOCEAN-IPSL (2005)  
    33    !! $Id: ldf_tra_smag.F90 1482 2010-06-13 15:28:06Z  $ 
     33   !! $Id$ 
    3434   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    3535   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/OBS/julian.F90

    r2715 r5620  
    2424      &   greg2jul            ! Convert date to relative time  
    2525   
     26   !! $Id$ 
    2627CONTAINS 
    2728  
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90

    r5038 r5620  
    1515   !!---------------------------------------------------------------------- 
    1616   !!---------------------------------------------------------------------- 
    17    !!   'key_oasis3'                    coupled Ocean/Atmosphere via OASIS3 
     17   !!   'key_oasis3'                    coupled Ocean/Atmosphere via OASIS3-MCT 
     18   !!   'key_oa3mct_v3'                 to be added for OASIS3-MCT version 3 
    1819   !!---------------------------------------------------------------------- 
    1920   !!   cpl_init     : initialization of coupled mode communication 
     
    6162#endif 
    6263 
    63    INTEGER, PUBLIC, PARAMETER ::   nmaxfld=40        ! Maximum number of coupling fields 
     64   INTEGER                    ::   nrcv         ! total number of fields received  
     65   INTEGER                    ::   nsnd         ! total number of fields sent  
     66   INTEGER                    ::   ncplmodel    ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 
     67   INTEGER, PUBLIC, PARAMETER ::   nmaxfld=50   ! Maximum number of coupling fields 
    6468   INTEGER, PUBLIC, PARAMETER ::   nmaxcat=5    ! Maximum number of coupling fields 
    6569   INTEGER, PUBLIC, PARAMETER ::   nmaxcpl=5    ! Maximum number of coupling fields 
     
    8690CONTAINS 
    8791 
    88    SUBROUTINE cpl_init( kl_comm ) 
     92   SUBROUTINE cpl_init( cd_modname, kl_comm ) 
    8993      !!------------------------------------------------------------------- 
    9094      !!             ***  ROUTINE cpl_init  *** 
     
    9599      !! ** Method  :   OASIS3 MPI communication  
    96100      !!-------------------------------------------------------------------- 
    97       INTEGER, INTENT(out) ::   kl_comm   ! local communicator of the model 
     101      CHARACTER(len = *), INTENT(in) ::   cd_modname   ! model name as set in namcouple file 
     102      INTEGER          , INTENT(out) ::   kl_comm      ! local communicator of the model 
    98103      !!-------------------------------------------------------------------- 
    99104 
     
    104109      ! 1st Initialize the OASIS system for the application 
    105110      !------------------------------------------------------------------ 
    106       CALL oasis_init_comp ( ncomp_id, 'oceanx', nerror ) 
     111      CALL oasis_init_comp ( ncomp_id, TRIM(cd_modname), nerror ) 
    107112      IF ( nerror /= OASIS_Ok ) & 
    108113         CALL oasis_abort (ncomp_id, 'cpl_init', 'Failure in oasis_init_comp') 
     
    144149      IF(lwp) WRITE(numout,*) 
    145150 
     151      ncplmodel = kcplmodel 
    146152      IF( kcplmodel > nmaxcpl ) THEN 
    147          CALL oasis_abort ( ncomp_id, 'cpl_define', 'kcplmodel is larger than nmaxcpl, increase nmaxcpl')   ;   RETURN 
     153         CALL oasis_abort ( ncomp_id, 'cpl_define', 'ncplmodel is larger than nmaxcpl, increase nmaxcpl')   ;   RETURN 
    148154      ENDIF 
     155 
     156      nrcv = krcv 
     157      IF( nrcv > nmaxfld ) THEN 
     158         CALL oasis_abort ( ncomp_id, 'cpl_define', 'nrcv is larger than nmaxfld, increase nmaxfld')   ;   RETURN 
     159      ENDIF 
     160 
     161      nsnd = ksnd 
     162      IF( nsnd > nmaxfld ) THEN 
     163         CALL oasis_abort ( ncomp_id, 'cpl_define', 'nsnd is larger than nmaxfld, increase nmaxfld')   ;   RETURN 
     164      ENDIF 
     165 
    149166      ! 
    150167      ! ... Define the shape for the area that excludes the halo 
     
    400417 
    401418 
    402    INTEGER FUNCTION cpl_freq( kid 
     419   INTEGER FUNCTION cpl_freq( cdfieldname 
    403420      !!--------------------------------------------------------------------- 
    404421      !!              ***  ROUTINE cpl_freq  *** 
     
    406423      !! ** Purpose : - send back the coupling frequency for a particular field 
    407424      !!---------------------------------------------------------------------- 
    408       INTEGER,INTENT(in) ::   kid   ! variable index 
    409       !! 
     425      CHARACTER(len = *), INTENT(in) ::   cdfieldname    ! field name as set in namcouple file 
     426      !! 
     427      INTEGER               :: id 
    410428      INTEGER               :: info 
    411429      INTEGER, DIMENSION(1) :: itmp 
     430      INTEGER               :: ji,jm     ! local loop index 
     431      INTEGER               :: mop 
    412432      !!---------------------------------------------------------------------- 
    413       CALL oasis_get_freqs(kid, 1, itmp, info) 
    414       cpl_freq = itmp(1) 
     433      cpl_freq = 0   ! defaut definition 
     434      id = -1        ! defaut definition 
     435      ! 
     436      DO ji = 1, nsnd 
     437         IF (ssnd(ji)%laction ) THEN 
     438            DO jm = 1, ncplmodel 
     439               IF( ssnd(ji)%nid(1,jm) /= -1 ) THEN 
     440                  IF( TRIM(cdfieldname) == TRIM(ssnd(ji)%clname) ) THEN 
     441                     id = ssnd(ji)%nid(1,jm) 
     442                     mop = OASIS_Out 
     443                  ENDIF 
     444               ENDIF 
     445            ENDDO 
     446         ENDIF 
     447      ENDDO 
     448      DO ji = 1, nrcv 
     449         IF (srcv(ji)%laction ) THEN 
     450            DO jm = 1, ncplmodel 
     451               IF( srcv(ji)%nid(1,jm) /= -1 ) THEN 
     452                  IF( TRIM(cdfieldname) == TRIM(srcv(ji)%clname) ) THEN 
     453                     id = srcv(ji)%nid(1,jm) 
     454                     mop = OASIS_In 
     455                  ENDIF 
     456               ENDIF 
     457            ENDDO 
     458         ENDIF 
     459      ENDDO 
     460      ! 
     461      IF( id /= -1 ) THEN 
     462#if defined key_oa3mct_v3 
     463         CALL oasis_get_freqs(id, mop, 1, itmp, info) 
     464#else 
     465         CALL oasis_get_freqs(id,      1, itmp, info) 
     466#endif 
     467         cpl_freq = itmp(1) 
     468      ENDIF 
    415469      ! 
    416470   END FUNCTION cpl_freq 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/cyclone.F90

    • Property svn:keywords set to Id
    r4230 r5620  
    4141   !!---------------------------------------------------------------------- 
    4242   !! NEMO/OPA 3.3 , LOCEAN-IPSL (2010)  
    43    !! $Id: module_example 1146 2008-06-25 11:42:56Z rblod $  
     43   !! $Id$  
    4444   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    4545   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r5035 r5620  
    7171   END TYPE FLD 
    7272 
    73    TYPE, PUBLIC ::   MAP_POINTER      !: Array of integer pointers to 1D arrays 
    74       INTEGER, POINTER   ::  ptr(:) 
     73   TYPE, PUBLIC ::   MAP_POINTER      !: Map from input data file to local domain 
     74      INTEGER, POINTER, DIMENSION(:)  ::  ptr           ! Array of integer pointers to 1D arrays 
     75      LOGICAL                         ::  ll_unstruc    ! Unstructured (T) or structured (F) boundary data file 
    7576   END TYPE MAP_POINTER 
    7677 
     
    115116CONTAINS 
    116117 
    117    SUBROUTINE fld_read( kt, kn_fsbc, sd, map, kit, kt_offset, jpk_bdy ) 
     118   SUBROUTINE fld_read( kt, kn_fsbc, sd, map, kit, kt_offset, jpk_bdy, fvl ) 
    118119      !!--------------------------------------------------------------------- 
    119120      !!                    ***  ROUTINE fld_read  *** 
     
    138139      !! 
    139140      INTEGER  , INTENT(in   ), OPTIONAL     ::   jpk_bdy   ! number of vertical levels in the BDY data 
     141      LOGICAL  , INTENT(in   ), OPTIONAL     ::   fvl   ! number of vertical levels in the BDY data 
    140142      !! 
    141143      INTEGER  ::   itmp       ! temporary variable 
     
    157159      IF( PRESENT(kit) )   ll_firstcall = ll_firstcall .and. kit == 1 
    158160 
    159       it_offset = 0 
     161      IF ( nn_components == jp_iam_sas ) THEN   ;   it_offset = nn_fsbc 
     162      ELSE                                      ;   it_offset = 0 
     163      ENDIF 
    160164      IF( PRESENT(kt_offset) )   it_offset = kt_offset 
    161165 
     
    174178            IF( PRESENT(map) ) imap = map(jf) 
    175179               IF( PRESENT(jpk_bdy) ) THEN 
    176                   CALL fld_init( kn_fsbc, sd(jf), imap, jpk_bdy )  ! read each before field (put them in after as they will be swapped) 
     180                  CALL fld_init( kn_fsbc, sd(jf), imap, jpk_bdy, fvl )  ! read each before field (put them in after as they will be swapped) 
    177181               ELSE 
    178182                  CALL fld_init( kn_fsbc, sd(jf), imap )  ! read each before field (put them in after as they will be swapped) 
     
    270274               ! read after data 
    271275               IF( PRESENT(jpk_bdy) ) THEN 
    272                   CALL fld_get( sd(jf), imap, jpk_bdy) 
     276                  CALL fld_get( sd(jf), imap, jpk_bdy, fvl) 
    273277               ELSE 
    274278                  CALL fld_get( sd(jf), imap ) 
     
    314318 
    315319 
    316    SUBROUTINE fld_init( kn_fsbc, sdjf, map , jpk_bdy) 
     320   SUBROUTINE fld_init( kn_fsbc, sdjf, map , jpk_bdy, fvl) 
    317321      !!--------------------------------------------------------------------- 
    318322      !!                    ***  ROUTINE fld_init  *** 
     
    325329      TYPE(MAP_POINTER),INTENT(in)     :: map       ! global-to-local mapping indices 
    326330      INTEGER  , INTENT(in), OPTIONAL  :: jpk_bdy   ! number of vertical levels in the BDY data 
     331      LOGICAL  , INTENT(in), OPTIONAL  :: fvl   ! number of vertical levels in the BDY data 
    327332      !! 
    328333      LOGICAL :: llprevyr              ! are we reading previous year  file? 
     
    420425         ! read before data in after arrays(as we will swap it later) 
    421426         IF( PRESENT(jpk_bdy) ) THEN 
    422             CALL fld_get( sdjf, map, jpk_bdy ) 
     427            CALL fld_get( sdjf, map, jpk_bdy, fvl ) 
    423428         ELSE 
    424429            CALL fld_get( sdjf, map ) 
     
    467472      ENDIF 
    468473      ! 
    469       it_offset = 0 
     474      IF ( nn_components == jp_iam_sas ) THEN   ;   it_offset = nn_fsbc 
     475      ELSE                                      ;   it_offset = 0 
     476      ENDIF 
    470477      IF( PRESENT(kt_offset) )   it_offset = kt_offset 
    471478      IF( PRESENT(kit) ) THEN   ;   it_offset = ( kit + it_offset ) * NINT( rdt/REAL(nn_baro,wp) ) 
     
    597604 
    598605 
    599    SUBROUTINE fld_get( sdjf, map, jpk_bdy ) 
     606   SUBROUTINE fld_get( sdjf, map, jpk_bdy, fvl ) 
    600607      !!--------------------------------------------------------------------- 
    601608      !!                    ***  ROUTINE fld_get  *** 
     
    606613      TYPE(MAP_POINTER),INTENT(in)    ::   map     ! global-to-local mapping indices 
    607614      INTEGER  , INTENT(in), OPTIONAL ::   jpk_bdy ! number of vertical levels in the bdy data 
     615      LOGICAL  , INTENT(in), OPTIONAL ::   fvl ! number of vertical levels in the bdy data 
    608616      !! 
    609617      INTEGER                  ::   ipk    ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
     
    620628         IF( PRESENT(jpk_bdy) ) THEN 
    621629            IF( sdjf%ln_tint ) THEN   ;    
    622                CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map%ptr, sdjf%igrd, sdjf%ibdy, jpk_bdy ) 
     630               CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl ) 
    623631            ELSE                      ;    
    624                CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1), map%ptr, sdjf%igrd, sdjf%ibdy, jpk_bdy ) 
     632               CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl ) 
    625633            ENDIF 
    626634         ELSE 
    627635            IF( sdjf%ln_tint ) THEN   ;    
    628                CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map%ptr ) 
     636               CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 
    629637            ELSE                      ;    
    630                CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1), map%ptr ) 
     638               CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1), map ) 
    631639            ENDIF 
    632640         ENDIF 
     
    685693   END SUBROUTINE fld_get 
    686694 
    687    SUBROUTINE fld_map( num, clvar, dta, nrec, map, igrd, ibdy, jpk_bdy ) 
     695   SUBROUTINE fld_map( num, clvar, dta, nrec, map, igrd, ibdy, jpk_bdy, fvl ) 
    688696      !!--------------------------------------------------------------------- 
    689697      !!                    ***  ROUTINE fld_map  *** 
     
    693701      !!---------------------------------------------------------------------- 
    694702#if defined key_bdy 
    695       USE bdy_oce, ONLY:  dta_global, dta_global_z, dta_global2, dta_global2_z         ! workspace to read in global data arrays 
     703      USE bdy_oce, ONLY:  idx_bdy, dta_global, dta_global_z, dta_global_dz, dta_global2, dta_global2_z, dta_global2_dz                 ! workspace to read in global data arrays 
    696704#endif  
    697705      INTEGER                   , INTENT(in ) ::   num     ! stream number 
     
    699707      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   dta   ! output field on model grid (2 dimensional) 
    700708      INTEGER                   , INTENT(in ) ::   nrec    ! record number to read (ie time slice) 
    701       INTEGER,  DIMENSION(:)    , INTENT(in ) ::   map     ! global-to-local mapping indices 
     709      TYPE(MAP_POINTER)         , INTENT(in ) ::   map     ! global-to-local mapping indices 
    702710      INTEGER  , INTENT(in), OPTIONAL         ::   igrd, ibdy, jpk_bdy  ! grid type, set number and number of vertical levels in the bdy data 
     711      LOGICAL  , INTENT(in), OPTIONAL         ::   fvl  ! grid type, set number and number of vertical levels in the bdy data 
    703712      INTEGER                                 ::   jpkm1_bdy! number of vertical levels in the bdy data minus 1 
    704713      !! 
     
    713722      REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read    ! work space for global data 
    714723      REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read_z  ! work space for global data 
     724      REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read_dz ! work space for global data 
    715725      !!--------------------------------------------------------------------- 
    716726             
     
    724734#if defined key_bdy 
    725735      ipj = iom_file(num)%dimsz(2,idvar) 
    726       IF (ipj == 1) THEN  
     736      IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 
    727737         dta_read => dta_global 
    728738         IF( PRESENT(jpk_bdy) ) THEN 
    729739            IF( jpk_bdy>0 ) THEN 
    730740               dta_read_z => dta_global_z 
     741               dta_read_dz => dta_global_dz 
    731742               jpkm1_bdy = jpk_bdy-1 
    732743            ENDIF 
    733744         ENDIF 
    734       ELSE ! we assume that this is a structured open boundary file 
     745      ELSE ! structured open boundary file 
    735746         dta_read => dta_global2 
    736747         IF( PRESENT(jpk_bdy) ) THEN 
    737748            IF( jpk_bdy>0 ) THEN 
    738749               dta_read_z => dta_global2_z 
     750               dta_read_dz => dta_global2_dz 
    739751               jpkm1_bdy = jpk_bdy-1 
    740752            ENDIF 
     
    750762      CASE DEFAULT   ;    
    751763   
     764      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     765      ! Do we include something here to adjust barotropic velocities ! 
     766      ! in case of a depth difference between bdy files and          ! 
     767      ! bathymetry in the case ln_full_vel = .false. and jpk_bdy>0?  ! 
     768      ! [as the enveloping and parital cells could change H          ! 
     769      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     770 
    752771      IF( PRESENT(jpk_bdy) .AND. jpk_bdy>0 ) THEN       ! boundary data not on model grid: vertical interpolation 
    753772         CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:jpk_bdy), nrec ) 
     
    764783         END SELECT 
    765784         CALL iom_getatt(num, '_FillValue', fv, cdvar=clvar ) 
     785 
    766786#if defined key_bdy 
    767          CALL fld_bdy_interp(dta_read, dta_read_z, map, jpk_bdy, igrd, ibdy, fv, dta) 
     787         CALL fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl) 
    768788#endif 
    769789      ELSE ! boundary data assumed to be on model grid 
     
    772792            DO ib = 1, ipi 
    773793              DO ik = 1, ipk 
    774                 dta(ib,1,ik) =  dta_read(map(ib),1,ik) 
     794                dta(ib,1,ik) =  dta_read(map%ptr(ib),1,ik) 
    775795              END DO 
    776796            END DO 
    777797         ELSE ! we assume that this is a structured open boundary file 
    778798            DO ib = 1, ipi 
    779                jj=1+floor(REAL(map(ib)-1)/REAL(ilendta)) 
    780                ji=map(ib)-(jj-1)*ilendta 
     799               jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
     800               ji=map%ptr(ib)-(jj-1)*ilendta 
    781801               DO ik = 1, ipk 
    782802                  dta(ib,1,ik) =  dta_read(ji,jj,ik) 
     
    790810    
    791811#if defined key_bdy 
    792    SUBROUTINE fld_bdy_interp(dta_read, dta_read_z, map, jpk_bdy, igrd, ibdy, fv, dta) 
     812   SUBROUTINE fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl) 
    793813 
    794814      !!--------------------------------------------------------------------- 
     
    802822      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read    ! work space for global data 
    803823      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read_z  ! work space for global data 
     824      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read_dz  ! work space for global data 
    804825      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   dta        ! output field on model grid (2 dimensional) 
    805       INTEGER,  DIMENSION(:)    , INTENT(in ) ::   map        ! global-to-local mapping indices 
     826      TYPE(MAP_POINTER)         , INTENT(in ) ::   map     ! global-to-local mapping indices 
     827      LOGICAL  , INTENT(in), OPTIONAL         ::   fvl  ! grid type, set number and number of vertical levels in the bdy data 
    806828      INTEGER  , INTENT(in)                   ::   igrd, ibdy, jpk_bdy      ! number of levels in bdy data 
    807829      INTEGER                                 ::   jpkm1_bdy    ! number of levels in bdy data minus 1 
     
    810832      INTEGER                                 ::   ipi        ! length of boundary data on local process 
    811833      INTEGER                                 ::   ipj        ! length of dummy dimension ( = 1 ) 
    812       INTEGER                                 ::   ipk, ipkm1 ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
     834      INTEGER                                 ::   ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
    813835      INTEGER                                 ::   ilendta    ! length of data in file 
    814836      INTEGER                                 ::   ib, ik, ikk! loop counters 
    815837      INTEGER                                 ::   ji, jj ! loop counters 
    816       REAL(wp)                                ::   zl, zi     ! tmp variable for current depth and interpolation factor 
    817       REAL(wp)                                ::   fv_alt ! fillvalue and alternative -ABS(fv) 
     838      REAL(wp)                                ::   zl, zi, zh, zz, zdz    ! tmp variable for current depth and interpolation factor 
     839      REAL(wp)                                ::   fv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(fv) 
    818840      !!--------------------------------------------------------------------- 
    819841 
     
    826848      fv_alt = -ABS(fv)  ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later 
    827849      ! 
    828       IF (ipj==1) THEN ! we assume that this is an un-structured open boundary file 
     850      IF ( map%ll_unstruc ) THEN ! unstructured open boundary data file 
    829851         DO ib = 1, ipi 
    830852            DO ik = 1, jpk_bdy 
    831                IF( ( dta_read(map(ib),1,ik) == fv ) ) THEN 
    832                   dta_read_z(map(ib),1,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 
    833                   dta_read_dz(map(ib),1,ik) = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 
    834                ENDIF 
    835       !           dta(ib,1,ik) = fv_alt    ! put fillvalue into new field as if all goes well all wet points will be replaced 
     853               IF( ( dta_read(map%ptr(ib),1,ik) == fv ) ) THEN 
     854                  dta_read_z(map%ptr(ib),1,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 
     855                  dta_read_dz(map%ptr(ib),1,ik) = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 
     856               ENDIF 
    836857            ENDDO 
    837858         ENDDO  
    838       ! 
     859 
    839860         DO ib = 1, ipi 
    840861            DO ik = 1, ipk                       
    841862               zl =  gdept_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik)   ! if using in step could use fsdept instead of gdept_0? 
    842                IF( zl < dta_read_z(map(ib),1,1) ) THEN                                         ! above the first level of external data 
    843                   dta(ib,1,ik) =  dta_read(map(ib),1,1) 
    844                ELSEIF( zl > MAXVAL(dta_read_z(map(ib),1,:),1) ) THEN                           ! below the last level of external data  
    845                   dta(ib,1,ik) =  dta_read(map(ib),1,MAXLOC(dta_read_z(map(ib),1,:),1)) 
     863               IF( zl < dta_read_z(map%ptr(ib),1,1) ) THEN                                         ! above the first level of external data 
     864                  dta(ib,1,ik) =  dta_read(map%ptr(ib),1,1) 
     865               ELSEIF( zl > MAXVAL(dta_read_z(map%ptr(ib),1,:),1) ) THEN                           ! below the last level of external data  
     866                  dta(ib,1,ik) =  dta_read(map%ptr(ib),1,MAXLOC(dta_read_z(map%ptr(ib),1,:),1)) 
    846867               ELSE                                                                          ! inbetween : vertical interpolation between ikk & ikk+1 
    847868                  DO ikk = 1, jpkm1_bdy                                                          ! when  gdept_0(ikk) < zl < gdept_0(ikk+1) 
    848                      IF( ( (zl-dta_read_z(map(ib),1,ikk)) * (zl-dta_read_z(map(ib),1,ikk+1)) <= 0._wp)   & 
    849                     &    .AND. (dta_read_z(map(ib),1,ikk+1) /= fv_alt)) THEN 
    850                         zi = ( zl - dta_read_z(map(ib),1,ikk) ) / (dta_read_z(map(ib),1,ikk+1)-dta_read_z(map(ib),1,ikk)) 
    851                         dta(ib,1,ik) = dta_read(map(ib),1,ikk) + & 
    852                       &                ( dta_read(map(ib),1,ikk+1) -  dta_read(map(ib),1,ikk) ) * zi 
     869                     IF( ( (zl-dta_read_z(map%ptr(ib),1,ikk)) * (zl-dta_read_z(map%ptr(ib),1,ikk+1)) <= 0._wp)   & 
     870                    &    .AND. (dta_read_z(map%ptr(ib),1,ikk+1) /= fv_alt)) THEN 
     871                        zi = ( zl - dta_read_z(map%ptr(ib),1,ikk) ) / (dta_read_z(map%ptr(ib),1,ikk+1)-dta_read_z(map%ptr(ib),1,ikk)) 
     872                        dta(ib,1,ik) = dta_read(map%ptr(ib),1,ikk) + & 
     873                      &                ( dta_read(map%ptr(ib),1,ikk+1) -  dta_read(map%ptr(ib),1,ikk) ) * zi 
    853874                     ENDIF 
    854875                  END DO 
     
    856877            END DO 
    857878         END DO 
    858       ELSE ! we assume that this is a structured open boundary file 
     879 
     880         IF(igrd == 2) THEN ! do we need to adjust the transport term? 
     881           DO ib = 1, ipi 
     882              zh = SUM(dta_read_dz(map%ptr(ib),1,:) ) 
     883              ztrans = 0._wp 
     884              ztrans_new = 0._wp 
     885              DO ik = 1, jpk_bdy 
     886                  ztrans = ztrans + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 
     887              ENDDO 
     888              DO ik = 1, ipk 
     889                  zdz =  e3u_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik)  
     890                  ztrans_new = ztrans_new + dta(ib,1,ik) * zdz 
     891              ENDDO 
     892              DO ik = 1, ipk 
     893                 zdz =  e3u_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik)    
     894                 zz  =  hur(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd))    
     895                 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
     896                    dta(ib,1,ik) = dta(ib,1,ik) + ( ztrans - ztrans_new ) * ( zdz * zz ) 
     897                 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
     898                    dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * ( zdz * zz ) 
     899                 ENDIF 
     900              ENDDO 
     901            ENDDO 
     902         ENDIF 
     903 
     904         IF(igrd == 3) THEN ! do we need to adjust the transport term? 
     905           DO ib = 1, ipi 
     906              zh = SUM(dta_read_dz(map%ptr(ib),1,:) ) 
     907              ztrans = 0._wp 
     908              ztrans_new = 0._wp 
     909              DO ik = 1, jpk_bdy 
     910                  ztrans = ztrans + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 
     911              ENDDO 
     912              DO ik = 1, ipk 
     913                  zdz =  e3v_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik)  
     914                  ztrans_new = ztrans_new + dta(ib,1,ik) * zdz 
     915              ENDDO 
     916              DO ik = 1, ipk 
     917                 zdz =  e3v_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik)    
     918                 zz  =  hvr(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd))    
     919                 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
     920                    dta(ib,1,ik) = dta(ib,1,ik) + ( ztrans - ztrans_new ) * ( zdz * zz ) 
     921                 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
     922                    dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * ( zdz * zz ) 
     923                 ENDIF 
     924              ENDDO 
     925            ENDDO 
     926         ENDIF 
     927   
     928         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     929         ! At this point write out a single velocity profile/dz/H for model and input data             ! 
     930         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     931 
     932      ELSE ! structured open boundary file 
    859933         DO ib = 1, ipi 
    860             jj=1+floor(REAL(map(ib)-1)/REAL(ilendta)) 
    861             ji=map(ib)-(jj-1)*ilendta 
     934            jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
     935            ji=map%ptr(ib)-(jj-1)*ilendta 
    862936            DO ik = 1, jpk_bdy                       
    863937               IF( ( dta_read(ji,jj,ik) == fv ) ) THEN 
    864                   dta_read_z(map(ib),1,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 
     938                  dta_read_z(ji,jj,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 
     939                  dta_read_dz(ji,jj,ik) = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 
    865940               ENDIF 
    866941     !            dta(ib,1,ik) = fv_alt    ! put fillvalue into new field as if all goes well all wet points will be replaced 
     
    869944      ! 
    870945         DO ib = 1, ipi 
    871             jj=1+floor(REAL(map(ib)-1)/REAL(ilendta)) 
    872             ji=map(ib)-(jj-1)*ilendta 
     946            jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
     947            ji=map%ptr(ib)-(jj-1)*ilendta 
    873948            DO ik = 1, ipk                       
    874949               zl =  gdept_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik)   ! if using in step could use fsdept instead of gdept_0? 
     
    892967 
    893968   END SUBROUTINE fld_bdy_interp 
    894    SUBROUTINE fld_bdy_conserve(dta_read, dta_read_z, map, jpk_bdy, igrd, ibdy, fv, dta) 
    895  
    896    END SUBROUTINE fld_bdy_conserve 
     969 
     970!  SUBROUTINE fld_bdy_conserve(dta_read, dta_read_z, map, jpk_bdy, igrd, ibdy, fv, dta) 
     971 
     972!  END SUBROUTINE fld_bdy_conserve 
    897973 
    898974#endif 
     
    11931269      INTEGER                           ::   ipk           ! temporary vertical dimension 
    11941270      CHARACTER (len=5)                 ::   aname 
    1195       INTEGER , DIMENSION(3)            ::   ddims 
     1271      INTEGER , DIMENSION(:), ALLOCATABLE ::   ddims 
    11961272      INTEGER , POINTER, DIMENSION(:,:) ::   data_src 
    11971273      REAL(wp), POINTER, DIMENSION(:,:) ::   data_tmp 
     
    12161292 
    12171293      !! get dimensions 
     1294      IF ( SIZE(sd%fnow, 3) > 1 ) THEN 
     1295         ALLOCATE( ddims(4) ) 
     1296      ELSE 
     1297         ALLOCATE( ddims(3) ) 
     1298      ENDIF 
    12181299      id = iom_varid( inum, sd%clvar, ddims ) 
    12191300 
     
    13121393         CALL ctl_stop( '    fld_weight : unable to read the file ' ) 
    13131394      ENDIF 
     1395 
     1396      DEALLOCATE (ddims ) 
    13141397 
    13151398      CALL wrk_dealloc( jpi,jpj, data_src )   ! integer 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r5038 r5620  
    1616   USE sbc_oce          ! surface boundary condition: ocean 
    1717# if defined key_lim3 
    18    USE par_ice          ! LIM-3 parameters 
     18   USE ice              ! LIM-3 parameters 
    1919# endif 
    2020# if defined key_lim2 
     
    5858   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qns_ice        !: non solar heat flux over ice                  [W/m2] 
    5959   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qsr_ice        !: solar heat flux over ice                      [W/m2] 
    60    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qsr_ice_mean   !: daily mean solar heat flux over ice           [W/m2] 
    6160   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qla_ice        !: latent flux over ice                          [W/m2] 
    6261   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dqla_ice       !: latent sensibility over ice                 [W/m2/K] 
     
    6968   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fr1_i0         !: Solar surface transmission parameter, thick ice  [-] 
    7069   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fr2_i0         !: Solar surface transmission parameter, thin ice   [-] 
    71    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_ice        !: sublimation - precip over sea ice            [kg/m2] 
     70   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_ice        !: sublimation - precip over sea ice          [kg/m2/s] 
    7271 
    7372   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   topmelt            !: category topmelt 
    7473   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   botmelt            !: category botmelt 
     74 
     75#if defined  key_lim3 
     76   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   evap_ice       !: sublimation                              [kg/m2/s] 
     77   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   devap_ice      !: sublimation sensitivity                [kg/m2/s/K] 
     78   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qns_oce        !: non solar heat flux over ocean              [W/m2] 
     79   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qsr_oce        !: non solar heat flux over ocean              [W/m2] 
     80   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_oce       !: heat flux of precip and evap over ocean     [W/m2] 
     81   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_ice       !: heat flux of precip and evap over ice       [W/m2] 
     82   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: heat flux of precip over ice                [J/m3] 
     83   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_oce        !: evap - precip over ocean                 [kg/m2/s] 
     84#endif 
     85#if defined key_lim3 || defined key_lim2 
     86   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wndm_ice       !: wind speed module at T-point                 [m/s] 
     87#endif 
    7588 
    7689#if defined key_cice 
     
    100113#endif 
    101114 
    102 #if defined key_lim3 || defined key_cice 
    103    ! not used with LIM2 
     115#if defined key_cice 
    104116   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   tatm_ice       !: air temperature [K] 
    105117#endif 
     
    125137      ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) ,     & 
    126138         &      qla_ice (jpi,jpj,jpl) , dqla_ice(jpi,jpj,jpl) ,     & 
    127          &      dqns_ice(jpi,jpj,jpl) , tn_ice  (jpi,jpj,jpl) ,     & 
    128          &      alb_ice (jpi,jpj,jpl) ,                             & 
    129          &      utau_ice(jpi,jpj)     , vtau_ice(jpi,jpj)     ,     & 
     139         &      dqns_ice(jpi,jpj,jpl) , tn_ice  (jpi,jpj,jpl) , alb_ice (jpi,jpj,jpl) ,   & 
     140         &      utau_ice(jpi,jpj)     , vtau_ice(jpi,jpj)     , wndm_ice(jpi,jpj)     ,   & 
    130141         &      fr1_i0  (jpi,jpj)     , fr2_i0  (jpi,jpj)     ,     & 
    131 #if defined key_lim3 
    132          &      tatm_ice(jpi,jpj)     ,                             & 
    133 #endif 
    134142#if defined key_lim2 
    135143         &      a_i(jpi,jpj,jpl)      ,                             & 
     144#endif 
     145#if defined key_lim3 
     146         &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,  & 
     147         &      qemp_ice(jpi,jpj)     , qemp_oce(jpi,jpj)      ,                       & 
     148         &      qns_oce (jpi,jpj)     , qsr_oce (jpi,jpj)      , emp_oce (jpi,jpj)  ,  & 
    136149#endif 
    137150         &      emp_ice(jpi,jpj)      ,  STAT= ierr(1) ) 
     
    145158                a_i(jpi,jpj,ncat)     , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , & 
    146159                STAT= ierr(1) ) 
    147       IF( lk_cpl )   ALLOCATE( u_ice(jpi,jpj)        , fr1_i0(jpi,jpj)       , tn_ice (jpi,jpj,1)    , & 
     160      IF( ln_cpl )   ALLOCATE( u_ice(jpi,jpj)        , fr1_i0(jpi,jpj)       , tn_ice (jpi,jpj,1)    , & 
    148161         &                     v_ice(jpi,jpj)        , fr2_i0(jpi,jpj)       , alb_ice(jpi,jpj,1)    , & 
    149162         &                     emp_ice(jpi,jpj)      , qns_ice(jpi,jpj,1)    , dqns_ice(jpi,jpj,1)   , & 
     
    152165#endif 
    153166         ! 
    154 #if defined key_lim2 
    155       IF( ltrcdm2dc_ice )   ALLOCATE( qsr_ice_mean (jpi,jpj,jpl), STAT=ierr(3) ) 
    156 #endif 
    157          ! 
    158167#if defined key_cice || defined key_lim2 
    159       IF( lk_cpl )   ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(5) ) 
     168      IF( ln_cpl )   ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(5) ) 
    160169#endif 
    161170 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90

    r5038 r5620  
    3636   LOGICAL , PUBLIC ::   ln_blk_mfs     !: MFS  bulk formulation 
    3737#if defined key_oasis3 
    38    LOGICAL , PUBLIC ::   lk_cpl = .TRUE.  !: coupled formulation 
     38   LOGICAL , PUBLIC ::   lk_oasis = .TRUE.  !: OASIS used 
    3939#else 
    40    LOGICAL , PUBLIC ::   lk_cpl = .FALSE. !: coupled formulation 
    41 #endif 
     40   LOGICAL , PUBLIC ::   lk_oasis = .FALSE. !: OASIS unused 
     41#endif 
     42   LOGICAL , PUBLIC ::   ln_cpl         !: ocean-atmosphere coupled formulation 
     43   LOGICAL , PUBLIC ::   ln_mixcpl      !: ocean-atmosphere forced-coupled mixed formulation 
    4244   LOGICAL , PUBLIC ::   ln_dm2dc       !: Daily mean to Diurnal Cycle short wave (qsr) 
    4345   LOGICAL , PUBLIC ::   ln_rnf         !: runoffs / runoff mouths 
     
    5052   !                                             !: =1 levitating ice with mass and salt exchange but no presure effect 
    5153   !                                             !: =2 embedded sea-ice (full salt and mass exchanges and pressure) 
    52    INTEGER , PUBLIC :: nn_limflx        !: LIM3 Multi-category heat flux formulation 
     54   INTEGER , PUBLIC ::   nn_components  !: flag for sbc module (including sea-ice) coupling mode (see component definition below)  
     55   INTEGER , PUBLIC ::   nn_limflx      !: LIM3 Multi-category heat flux formulation 
    5356   !                                             !: =-1  Use of per-category fluxes 
    5457   !                                             !: = 0  Average per-category fluxes 
     
    6972   !!           switch definition (improve readability) 
    7073   !!---------------------------------------------------------------------- 
    71    INTEGER , PUBLIC, PARAMETER ::   jp_gyre    = 0        !: GYRE analytical formulation 
    72    INTEGER , PUBLIC, PARAMETER ::   jp_ana     = 1        !: analytical      formulation 
    73    INTEGER , PUBLIC, PARAMETER ::   jp_flx     = 2        !: flux            formulation 
    74    INTEGER , PUBLIC, PARAMETER ::   jp_clio    = 3        !: CLIO bulk       formulation 
    75    INTEGER , PUBLIC, PARAMETER ::   jp_core    = 4        !: CORE bulk       formulation 
    76    INTEGER , PUBLIC, PARAMETER ::   jp_cpl     = 5        !: Coupled         formulation 
    77    INTEGER , PUBLIC, PARAMETER ::   jp_mfs     = 6        !: MFS  bulk       formulation 
     74   INTEGER , PUBLIC, PARAMETER ::   jp_gyre    = 0        !: GYRE analytical               formulation 
     75   INTEGER , PUBLIC, PARAMETER ::   jp_ana     = 1        !: analytical                    formulation 
     76   INTEGER , PUBLIC, PARAMETER ::   jp_flx     = 2        !: flux                          formulation 
     77   INTEGER , PUBLIC, PARAMETER ::   jp_clio    = 3        !: CLIO bulk                     formulation 
     78   INTEGER , PUBLIC, PARAMETER ::   jp_core    = 4        !: CORE bulk                     formulation 
     79   INTEGER , PUBLIC, PARAMETER ::   jp_purecpl = 5        !: Pure ocean-atmosphere Coupled formulation 
     80   INTEGER , PUBLIC, PARAMETER ::   jp_mfs     = 6        !: MFS  bulk                     formulation 
     81   INTEGER , PUBLIC, PARAMETER ::   jp_none    = 7        !: for OPA when doing coupling via SAS module 
    7882   INTEGER , PUBLIC, PARAMETER ::   jp_esopa   = -1       !: esopa test, ALL formulations 
    7983    
    8084   !!---------------------------------------------------------------------- 
     85   !!           component definition 
     86   !!---------------------------------------------------------------------- 
     87   INTEGER , PUBLIC, PARAMETER ::   jp_iam_nemo = 0      !: Initial single executable configuration  
     88                                                         !  (no internal OASIS coupling) 
     89   INTEGER , PUBLIC, PARAMETER ::   jp_iam_opa  = 1      !: Multi executable configuration - OPA component 
     90                                                         !  (internal OASIS coupling) 
     91   INTEGER , PUBLIC, PARAMETER ::   jp_iam_sas  = 2      !: Multi executable configuration - SAS component 
     92                                                         !  (internal OASIS coupling) 
     93   !!---------------------------------------------------------------------- 
    8194   !!              Ocean Surface Boundary Condition fields 
    8295   !!---------------------------------------------------------------------- 
     96   INTEGER , PUBLIC ::  ncpl_qsr_freq            !: qsr coupling frequency per days from atmosphere 
     97   ! 
    8398   LOGICAL , PUBLIC ::   lhftau = .FALSE.        !: HF tau used in TKE: mean(stress module) - module(mean stress) 
    84    LOGICAL , PUBLIC ::   ltrcdm2dc               !: In case of Diurnal Cycle short wave, compute a Daily Mean short waves flux 
    8599   !!                                   !!   now    ! before   !! 
    86100   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   utau   , utau_b   !: sea surface i-stress (ocean referential)     [N/m2] 
     
    90104   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wndm              !: wind speed module at T-point (=|U10m-Uoce|)  [m/s] 
    91105   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr               !: sea heat flux:     solar                     [W/m2] 
    92    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr_mean          !: daily mean sea heat flux: solar              [W/m2] 
    93106   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qns    , qns_b    !: sea heat flux: non solar                     [W/m2] 
    94107   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr_tot           !: total     solar heat flux (over sea and ice) [W/m2] 
     
    98111   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp_tot           !: total E-P over ocean and ice                 [Kg/m2/s] 
    99112   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fmmflx            !: freshwater budget: freezing/melting          [Kg/m2/s] 
    100    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rnf    , rnf_b    !: river runoff   [Kg/m2/s]   
     113   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rnf    , rnf_b    !: river runoff        [Kg/m2/s]   
     114   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fwfisf , fwfisf_b !: ice shelf melting   [Kg/m2/s]   
    101115   !! 
    102116   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  sbc_tsc, sbc_tsc_b  !: sbc content trend                      [K.m/s] jpi,jpj,jpts 
     
    110124   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   atm_co2           !: atmospheric pCO2                             [ppm] 
    111125#endif 
     126   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask          !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) 
    112127 
    113128   !!---------------------------------------------------------------------- 
     
    121136   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssh_m     !: mean (nn_fsbc time-step) sea surface height                [m] 
    122137   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   e3t_m     !: mean (nn_fsbc time-step) sea surface layer thickness       [m] 
     138   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   frq_m     !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-] 
    123139 
    124140   !! * Substitutions 
     
    147163         &      sfx    (jpi,jpj) , sfx_b(jpi,jpj) , emp_tot(jpi,jpj), fmmflx(jpi,jpj), STAT=ierr(2) ) 
    148164         ! 
    149       ALLOCATE( rnf  (jpi,jpj) , sbc_tsc  (jpi,jpj,jpts) , qsr_hc  (jpi,jpj,jpk) ,     & 
    150          &      rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , STAT=ierr(3) ) 
     165      ALLOCATE( fwfisf  (jpi,jpj), rnf  (jpi,jpj) , sbc_tsc  (jpi,jpj,jpts) , qsr_hc  (jpi,jpj,jpk) ,     & 
     166         &      fwfisf_b(jpi,jpj), rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , STAT=ierr(3) ) 
    151167         ! 
    152168      ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) ,     & 
     
    154170         &      atm_co2(jpi,jpj) ,                                        & 
    155171#endif 
    156          &      ssu_m  (jpi,jpj) , sst_m(jpi,jpj) ,                       & 
    157          &      ssv_m  (jpi,jpj) , sss_m  (jpi,jpj), ssh_m(jpi,jpj) , STAT=ierr(4) ) 
     172         &      ssu_m  (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) ,      & 
     173         &      ssv_m  (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) 
    158174         ! 
    159175#if defined key_vvl 
    160176      ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) ) 
    161177#endif 
    162          ! 
    163       IF( ltrcdm2dc ) ALLOCATE( qsr_mean(jpi,jpj) , STAT=ierr(5) ) 
    164178         ! 
    165179      sbc_oce_alloc = MAXVAL( ierr ) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcapr.F90

    • Property svn:keywords set to Id
    r4792 r5620  
    4343   !!---------------------------------------------------------------------- 
    4444   !! NEMO/OPA 4.0 , NEMO Consortium (2011)  
    45    !! $Id: $ 
     45   !! $Id$ 
    4646   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4747   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

    r5038 r5620  
    3434   USE albedo 
    3535   USE prtctl          ! Print control 
    36 #if defined key_lim3 
     36#if defined key_lim3  
    3737   USE ice 
    3838   USE sbc_ice         ! Surface boundary condition: ice fields 
     39   USE limthd_dh       ! for CALL lim_thd_snwblow 
    3940#elif defined key_lim2 
    4041   USE ice_2 
     42   USE sbc_ice         ! Surface boundary condition: ice fields 
     43   USE par_ice_2       ! Surface boundary condition: ice fields 
    4144#endif 
    4245 
     
    4548 
    4649   PUBLIC sbc_blk_clio        ! routine called by sbcmod.F90  
    47    PUBLIC blk_ice_clio        ! routine called by sbcice_lim.F90  
     50#if defined key_lim2 || defined key_lim3 
     51   PUBLIC blk_ice_clio_tau    ! routine called by sbcice_lim.F90  
     52   PUBLIC blk_ice_clio_flx    ! routine called by sbcice_lim.F90  
     53#endif 
    4854 
    4955   INTEGER , PARAMETER ::   jpfld   = 7           ! maximum number of files to read  
     
    6268   LOGICAL ::   lbulk_init = .TRUE.               ! flag, bulk initialization done or not) 
    6369 
    64 #if ! defined key_lim3                           
    65    ! in namicerun with LIM3 
    6670   REAL(wp) ::   cai = 1.40e-3 ! best estimate of atm drag in order to get correct FS export in ORCA2-LIM 
    6771   REAL(wp) ::   cao = 1.00e-3 ! chosen by default  ==> should depends on many things...  !!gmto be updated 
    68 #endif 
    6972 
    7073   REAL(wp) ::   rdtbs2      !:    
     
    381384         &     + sf(jp_prec)%fnow(:,:,1) * sf(jp_tair)%fnow(:,:,1) * zcprec   ! add    precip. heat content at Tair in Celcius 
    382385      qns(:,:) = qns(:,:) * tmask(:,:,1) 
     386#if defined key_lim3 
     387      qns_oce(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) 
     388      qsr_oce(:,:) = qsr(:,:) 
     389#endif 
    383390      ! NB: if sea-ice model, the snow precip are computed and the associated heat is added to qns (see blk_ice_clio) 
    384391 
    385       CALL iom_put( "qlw_oce",   zqlw )   ! output downward longwave  heat over the ocean 
    386       CALL iom_put( "qsb_oce", - zqsb )   ! output downward sensible  heat over the ocean 
    387       CALL iom_put( "qla_oce", - zqla )   ! output downward latent    heat over the ocean 
    388       CALL iom_put( "qns_oce",   qns  )   ! output downward non solar heat over the ocean 
     392      IF ( nn_ice == 0 ) THEN 
     393         CALL iom_put( "qlw_oce" ,   zqlw )                 ! output downward longwave  heat over the ocean 
     394         CALL iom_put( "qsb_oce" , - zqsb )                 ! output downward sensible  heat over the ocean 
     395         CALL iom_put( "qla_oce" , - zqla )                 ! output downward latent    heat over the ocean 
     396         CALL iom_put( "qemp_oce",   qns-zqlw+zqsb+zqla )   ! output downward heat content of E-P over the ocean 
     397         CALL iom_put( "qns_oce" ,   qns  )                 ! output downward non solar heat over the ocean 
     398         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean 
     399         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean 
     400      ENDIF 
    389401 
    390402      IF(ln_ctl) THEN 
     
    402414   END SUBROUTINE blk_oce_clio 
    403415 
    404  
    405    SUBROUTINE blk_ice_clio(  pst   , palb_cs, palb_os, palb,  & 
    406       &                      p_taui, p_tauj, p_qns , p_qsr,   & 
    407       &                      p_qla , p_dqns, p_dqla,          & 
    408       &                      p_tpr , p_spr ,                  & 
    409       &                      p_fr1 , p_fr2 , cd_grid, pdim  ) 
     416# if defined key_lim2 || defined key_lim3 
     417   SUBROUTINE blk_ice_clio_tau 
    410418      !!--------------------------------------------------------------------------- 
    411       !!                     ***  ROUTINE blk_ice_clio  *** 
     419      !!                     ***  ROUTINE blk_ice_clio_tau  *** 
     420      !!                  
     421      !!  ** Purpose :   Computation momentum flux at the ice-atm interface   
     422      !!          
     423      !!  ** Method  :   Read utau from a forcing file. Rearrange if C-grid 
     424      !! 
     425      !!---------------------------------------------------------------------- 
     426      REAL(wp) ::   zcoef 
     427      INTEGER  ::   ji, jj   ! dummy loop indices 
     428      !!--------------------------------------------------------------------- 
     429      ! 
     430      IF( nn_timing == 1 )  CALL timing_start('blk_ice_clio_tau') 
     431 
     432      SELECT CASE( cp_ice_msh ) 
     433 
     434      CASE( 'C' )                          ! C-grid ice dynamics 
     435 
     436         zcoef  = cai / cao                         ! Change from air-sea stress to air-ice stress 
     437         utau_ice(:,:) = zcoef * utau(:,:) 
     438         vtau_ice(:,:) = zcoef * vtau(:,:) 
     439 
     440      CASE( 'I' )                          ! I-grid ice dynamics:  I-point (i.e. F-point lower-left corner) 
     441 
     442         zcoef  = 0.5_wp * cai / cao                ! Change from air-sea stress to air-ice stress 
     443         DO jj = 2, jpj         ! stress from ocean U- and V-points to ice U,V point 
     444            DO ji = 2, jpi   ! I-grid : no vector opt. 
     445               utau_ice(ji,jj) = zcoef * ( utau(ji-1,jj  ) + utau(ji-1,jj-1) ) 
     446               vtau_ice(ji,jj) = zcoef * ( vtau(ji  ,jj-1) + vtau(ji-1,jj-1) ) 
     447            END DO 
     448         END DO 
     449 
     450         CALL lbc_lnk( utau_ice(:,:), 'I', -1. )   ;   CALL lbc_lnk( vtau_ice(:,:), 'I', -1. )   ! I-point 
     451 
     452      END SELECT 
     453 
     454      IF(ln_ctl) THEN 
     455         CALL prt_ctl(tab2d_1=utau_ice , clinfo1=' blk_ice_clio: utau_ice : ', tab2d_2=vtau_ice , clinfo2=' vtau_ice : ') 
     456      ENDIF 
     457 
     458      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_clio_tau') 
     459 
     460   END SUBROUTINE blk_ice_clio_tau 
     461#endif 
     462 
     463# if defined key_lim2 || defined key_lim3 
     464   SUBROUTINE blk_ice_clio_flx(  ptsu , palb_cs, palb_os, palb ) 
     465      !!--------------------------------------------------------------------------- 
     466      !!                     ***  ROUTINE blk_ice_clio_flx *** 
    412467      !!                  
    413468      !!  ** Purpose :   Computation of the heat fluxes at ocean and snow/ice 
     
    431486      !!                         to take into account solid precip latent heat flux 
    432487      !!---------------------------------------------------------------------- 
    433       REAL(wp), INTENT(in   ), DIMENSION(:,:,:)   ::   pst      ! ice surface temperature                   [Kelvin] 
     488      REAL(wp), INTENT(in   ), DIMENSION(:,:,:)   ::   ptsu      ! ice surface temperature                   [Kelvin] 
    434489      REAL(wp), INTENT(in   ), DIMENSION(:,:,:)   ::   palb_cs  ! ice albedo (clear    sky) (alb_ice_cs)         [-] 
    435490      REAL(wp), INTENT(in   ), DIMENSION(:,:,:)   ::   palb_os  ! ice albedo (overcast sky) (alb_ice_os)         [-] 
    436491      REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   palb     ! ice albedo (actual value)                      [-] 
    437       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_taui   ! surface ice stress at I-point (i-component) [N/m2] 
    438       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_tauj   ! surface ice stress at I-point (j-component) [N/m2] 
    439       REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   p_qns    ! non solar heat flux over ice (T-point)      [W/m2] 
    440       REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   p_qsr    !     solar heat flux over ice (T-point)      [W/m2] 
    441       REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   p_qla    ! latent    heat flux over ice (T-point)      [W/m2] 
    442       REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   p_dqns   ! non solar heat sensistivity  (T-point)      [W/m2] 
    443       REAL(wp), INTENT(  out), DIMENSION(:,:,:)   ::   p_dqla   ! latent    heat sensistivity  (T-point)      [W/m2] 
    444       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_tpr    ! total precipitation          (T-point)   [Kg/m2/s] 
    445       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_spr    ! solid precipitation          (T-point)   [Kg/m2/s] 
    446       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_fr1    ! 1sr fraction of qsr penetration in ice         [-] 
    447       REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   p_fr2    ! 2nd fraction of qsr penetration in ice         [-] 
    448       CHARACTER(len=1), INTENT(in   )             ::   cd_grid  ! type of sea-ice grid ("C" or "B" grid) 
    449       INTEGER, INTENT(in   )                      ::   pdim     ! number of ice categories 
    450492      !! 
    451493      INTEGER  ::   ji, jj, jl    ! dummy loop indices 
    452       INTEGER  ::   ijpl          ! number of ice categories (size of 3rd dim of input arrays) 
    453       !! 
    454       REAL(wp) ::   zcoef, zmt1, zmt2, zmt3, ztatm3     ! temporary scalars 
     494      !! 
     495      REAL(wp) ::   zmt1, zmt2, zmt3, ztatm3                    ! temporary scalars 
    455496      REAL(wp) ::   ztaevbk, zind1, zind2, zind3, ztamr         !    -         - 
    456497      REAL(wp) ::   zesi, zqsati, zdesidt                       !    -         - 
     
    458499      REAL(wp) ::   zcshi, zclei, zrhovaclei, zrhovacshi        !    -         - 
    459500      REAL(wp) ::   ztice3, zticemb, zticemb2, zdqlw, zdqsb     !    -         - 
     501      REAL(wp) ::   z1_lsub                                     !    -         - 
    460502      !! 
    461503      REAL(wp), DIMENSION(:,:)  , POINTER ::   ztatm   ! Tair in Kelvin 
     
    464506      REAL(wp), DIMENSION(:,:)  , POINTER ::   zrhoa   ! air density 
    465507      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw, z_qsb 
     508      REAL(wp), DIMENSION(:,:)  , POINTER ::   zevap, zsnw 
    466509      !!--------------------------------------------------------------------- 
    467510      ! 
    468       IF( nn_timing == 1 )  CALL timing_start('blk_ice_clio') 
     511      IF( nn_timing == 1 )  CALL timing_start('blk_ice_clio_flx') 
    469512      ! 
    470513      CALL wrk_alloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 
    471       CALL wrk_alloc( jpi,jpj,pdim, z_qlw, z_qsb ) 
    472  
    473       ijpl  = pdim                           ! number of ice categories 
     514      CALL wrk_alloc( jpi,jpj, jpl, z_qlw, z_qsb ) 
     515 
    474516      zpatm = 101000.                        ! atmospheric pressure  (assumed constant  here) 
    475  
    476 #if defined key_lim3       
    477       tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1)   ! LIM3: make Tair available in sea-ice. WARNING allocated after call to ice_init 
    478 #endif 
    479       !                                                        ! surface ocean fluxes computed with CLIO bulk formulea 
    480       !------------------------------------! 
    481       !   momentum fluxes  (utau, vtau )   ! 
    482       !------------------------------------! 
    483  
    484       SELECT CASE( cd_grid ) 
    485       CASE( 'C' )                          ! C-grid ice dynamics 
    486          zcoef  = cai / cao                         ! Change from air-sea stress to air-ice stress 
    487          p_taui(:,:) = zcoef * utau(:,:) 
    488          p_tauj(:,:) = zcoef * vtau(:,:) 
    489       CASE( 'I' )                          ! I-grid ice dynamics:  I-point (i.e. F-point lower-left corner) 
    490          zcoef  = 0.5_wp * cai / cao                ! Change from air-sea stress to air-ice stress 
    491          DO jj = 2, jpj         ! stress from ocean U- and V-points to ice U,V point 
    492             DO ji = 2, jpi   ! I-grid : no vector opt. 
    493                p_taui(ji,jj) = zcoef * ( utau(ji-1,jj  ) + utau(ji-1,jj-1) ) 
    494                p_tauj(ji,jj) = zcoef * ( vtau(ji  ,jj-1) + vtau(ji-1,jj-1) ) 
    495             END DO 
    496          END DO 
    497          CALL lbc_lnk( p_taui(:,:), 'I', -1. )   ;   CALL lbc_lnk( p_tauj(:,:), 'I', -1. )   ! I-point 
    498       END SELECT 
    499  
    500  
     517      !-------------------------------------------------------------------------------- 
    501518      !  Determine cloud optical depths as a function of latitude (Chou et al., 1981). 
    502519      !  and the correction factor for taking into account  the effect of clouds  
    503       !------------------------------------------------------ 
     520      !-------------------------------------------------------------------------------- 
     521 
    504522!CDIR NOVERRCHK 
    505523!CDIR COLLAPSE 
     
    528546            zmt2  = ( 272.0 - ztatm(ji,jj) ) / 38.0   ;   zind2 = MAX( 0.e0, SIGN( 1.e0, zmt2 ) ) 
    529547            zmt3  = ( 281.0 - ztatm(ji,jj) ) / 18.0   ;   zind3 = MAX( 0.e0, SIGN( 1.e0, zmt3 ) ) 
    530             p_spr(ji,jj) = sf(jp_prec)%fnow(ji,jj,1) / rday   &      ! rday = converte mm/day to kg/m2/s 
     548            sprecip(ji,jj) = sf(jp_prec)%fnow(ji,jj,1) / rday   &      ! rday = converte mm/day to kg/m2/s 
    531549               &         * (          zind1      &                   ! solid  (snow) precipitation [kg/m2/s] 
    532550               &            + ( 1.0 - zind1 ) * (          zind2   * ( 0.5 + zmt2 )   & 
     
    538556            ! fraction of qsr_ice which is NOT absorbed in the thin surface layer 
    539557            ! and thus which penetrates inside the ice cover ( Maykut and Untersteiner, 1971 ; Elbert anbd Curry, 1993 ) 
    540             p_fr1(ji,jj) = 0.18  * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.35 * sf(jp_ccov)%fnow(ji,jj,1)  
    541             p_fr2(ji,jj) = 0.82  * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.65 * sf(jp_ccov)%fnow(ji,jj,1) 
    542          END DO 
    543       END DO 
    544       CALL iom_put( 'snowpre', p_spr )   ! Snow precipitation  
     558            fr1_i0(ji,jj) = 0.18  * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.35 * sf(jp_ccov)%fnow(ji,jj,1)  
     559            fr2_i0(ji,jj) = 0.82  * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.65 * sf(jp_ccov)%fnow(ji,jj,1) 
     560         END DO 
     561      END DO 
     562      CALL iom_put( 'snowpre', sprecip )   ! Snow precipitation  
    545563       
    546564      !-----------------------------------------------------------! 
    547565      !  snow/ice Shortwave radiation   (abedo already computed)  ! 
    548566      !-----------------------------------------------------------! 
    549       CALL blk_clio_qsr_ice( palb_cs, palb_os, p_qsr ) 
    550        
    551       DO jl = 1, ijpl 
     567      CALL blk_clio_qsr_ice( palb_cs, palb_os, qsr_ice ) 
     568       
     569      DO jl = 1, jpl 
    552570         palb(:,:,jl) = ( palb_cs(:,:,jl) * ( 1.e0 - sf(jp_ccov)%fnow(:,:,1) )   & 
    553571            &         +   palb_os(:,:,jl) * sf(jp_ccov)%fnow(:,:,1) ) 
     
    555573 
    556574      !                                     ! ========================== ! 
    557       DO jl = 1, ijpl                       !  Loop over ice categories  ! 
     575      DO jl = 1, jpl                       !  Loop over ice categories  ! 
    558576         !                                  ! ========================== ! 
    559577!CDIR NOVERRCHK 
     
    569587               ztaevbk = ztatm3 * ztatm(ji,jj) * zcldeff * ( 0.39 - 0.05 * zevsqr(ji,jj) )  
    570588               ! 
    571                z_qlw(ji,jj,jl) = - emic * stefan * ( ztaevbk + 4. * ztatm3 * ( pst(ji,jj,jl) - ztatm(ji,jj) ) )  
     589               z_qlw(ji,jj,jl) = - emic * stefan * ( ztaevbk + 4. * ztatm3 * ( ptsu(ji,jj,jl) - ztatm(ji,jj) ) )  
    572590 
    573591               !---------------------------------------- 
     
    576594 
    577595               ! vapour pressure at saturation of ice (tmask to avoid overflow in the exponential) 
    578                zesi =  611.0 * EXP( 21.8745587 * tmask(ji,jj,1) * ( pst(ji,jj,jl) - rtt )/ ( pst(ji,jj,jl) - 7.66 ) ) 
     596               zesi =  611.0 * EXP( 21.8745587 * tmask(ji,jj,1) * ( ptsu(ji,jj,jl) - rtt )/ ( ptsu(ji,jj,jl) - 7.66 ) ) 
    579597               ! humidity close to the ice surface (at saturation) 
    580598               zqsati   = ( 0.622 * zesi ) / ( zpatm - 0.378 * zesi ) 
    581599                
    582600               !  computation of intermediate values 
    583                zticemb  = pst(ji,jj,jl) - 7.66 
     601               zticemb  = ptsu(ji,jj,jl) - 7.66 
    584602               zticemb2 = zticemb * zticemb   
    585                ztice3   = pst(ji,jj,jl) * pst(ji,jj,jl) * pst(ji,jj,jl) 
     603               ztice3   = ptsu(ji,jj,jl) * ptsu(ji,jj,jl) * ptsu(ji,jj,jl) 
    586604               zdesidt  = zesi * ( 9.5 * LOG( 10.0 ) * ( rtt - 7.66 )  / zticemb2 ) 
    587605                
     
    596614             
    597615               !  sensible heat flux 
    598                z_qsb(ji,jj,jl) = zrhovacshi * ( pst(ji,jj,jl) - ztatm(ji,jj) ) 
     616               z_qsb(ji,jj,jl) = zrhovacshi * ( ptsu(ji,jj,jl) - ztatm(ji,jj) ) 
    599617             
    600618               !  latent heat flux  
    601                p_qla(ji,jj,jl) = MAX(  0.e0, zrhovaclei * ( zqsati - zqatm(ji,jj) )  ) 
     619               qla_ice(ji,jj,jl) = MAX(  0.e0, zrhovaclei * ( zqsati - zqatm(ji,jj) )  ) 
    602620               
    603621               !  sensitivity of non solar fluxes (dQ/dT) (long-wave, sensible and latent fluxes) 
     
    606624               zdqla = zrhovaclei * ( zdesidt * ( zqsati * zqsati / ( zesi * zesi ) ) * ( zpatm / 0.622 ) )    
    607625               ! 
    608                p_dqla(ji,jj,jl) = zdqla                           ! latent flux sensitivity 
    609                p_dqns(ji,jj,jl) = -( zdqlw + zdqsb + zdqla )      !  total non solar sensitivity 
     626               dqla_ice(ji,jj,jl) = zdqla                           ! latent flux sensitivity 
     627               dqns_ice(ji,jj,jl) = -( zdqlw + zdqsb + zdqla )      !  total non solar sensitivity 
    610628            END DO 
    611629            ! 
     
    619637      ! 
    620638!CDIR COLLAPSE 
    621       p_qns(:,:,:) = z_qlw (:,:,:) - z_qsb (:,:,:) - p_qla (:,:,:)      ! Downward Non Solar flux 
    622 !CDIR COLLAPSE 
    623       p_tpr(:,:)   = sf(jp_prec)%fnow(:,:,1) / rday                     ! total precipitation [kg/m2/s] 
     639      qns_ice(:,:,:) = z_qlw (:,:,:) - z_qsb (:,:,:) - qla_ice (:,:,:)      ! Downward Non Solar flux 
     640!CDIR COLLAPSE 
     641      tprecip(:,:)   = sf(jp_prec)%fnow(:,:,1) / rday                     ! total precipitation [kg/m2/s] 
    624642      ! 
    625643      ! ----------------------------------------------------------------------------- ! 
     
    628646!CDIR COLLAPSE 
    629647      qns(:,:) = qns(:,:)                                                           &   ! update the non-solar heat flux with: 
    630          &     - p_spr(:,:) * lfus                                                  &   ! remove melting solid precip 
    631          &     + p_spr(:,:) * MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow - rt0 ) * cpic &   ! add solid P at least below melting 
    632          &     - p_spr(:,:) * sf(jp_tair)%fnow(:,:,1)                        * rcp      ! remove solid precip. at Tair 
    633       ! 
     648         &     - sprecip(:,:) * lfus                                                  &   ! remove melting solid precip 
     649         &     + sprecip(:,:) * MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow - rt0 ) * cpic &   ! add solid P at least below melting 
     650         &     - sprecip(:,:) * sf(jp_tair)%fnow(:,:,1)                        * rcp      ! remove solid precip. at Tair 
     651 
     652#if defined key_lim3 
     653      ! ----------------------------------------------------------------------------- ! 
     654      !    Distribute evapo, precip & associated heat over ice and ocean 
     655      ! ---------------=====--------------------------------------------------------- ! 
     656      CALL wrk_alloc( jpi,jpj, zevap, zsnw )  
     657 
     658      ! --- evaporation --- ! 
     659      z1_lsub = 1._wp / Lsub 
     660      evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
     661      devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
     662      zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
     663 
     664      ! --- evaporation minus precipitation --- ! 
     665      zsnw(:,:) = 0._wp 
     666      CALL lim_thd_snwblow( pfrld, zsnw )          ! snow redistribution by wind 
     667      emp_oce(:,:) = pfrld(:,:) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * ( 1._wp - zsnw ) 
     668      emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw 
     669      emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) 
     670 
     671      ! --- heat flux associated with emp --- ! 
     672      qemp_oce(:,:) = - pfrld(:,:) * zevap(:,:) * sst_m(:,:) * rcp                               & ! evap 
     673         &          + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp  & ! liquid precip 
     674         &          +   sprecip(:,:) * ( 1._wp - zsnw ) *                                        & ! solid precip 
     675         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     676      qemp_ice(:,:) =   sprecip(:,:) * zsnw *                                                    & ! solid precip (only) 
     677         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     678 
     679      ! --- total solar and non solar fluxes --- ! 
     680      qns_tot(:,:) = pfrld(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) 
     681      qsr_tot(:,:) = pfrld(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) 
     682 
     683      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     684      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     685 
     686      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
     687#endif 
     688 
    634689!!gm : not necessary as all input data are lbc_lnk... 
    635       CALL lbc_lnk( p_fr1  (:,:) , 'T', 1. ) 
    636       CALL lbc_lnk( p_fr2  (:,:) , 'T', 1. ) 
    637       DO jl = 1, ijpl 
    638          CALL lbc_lnk( p_qns (:,:,jl) , 'T', 1. ) 
    639          CALL lbc_lnk( p_dqns(:,:,jl) , 'T', 1. ) 
    640          CALL lbc_lnk( p_qla (:,:,jl) , 'T', 1. ) 
    641          CALL lbc_lnk( p_dqla(:,:,jl) , 'T', 1. ) 
     690      CALL lbc_lnk( fr1_i0  (:,:) , 'T', 1. ) 
     691      CALL lbc_lnk( fr2_i0  (:,:) , 'T', 1. ) 
     692      DO jl = 1, jpl 
     693         CALL lbc_lnk( qns_ice (:,:,jl) , 'T', 1. ) 
     694         CALL lbc_lnk( dqns_ice(:,:,jl) , 'T', 1. ) 
     695         CALL lbc_lnk( qla_ice (:,:,jl) , 'T', 1. ) 
     696         CALL lbc_lnk( dqla_ice(:,:,jl) , 'T', 1. ) 
    642697      END DO 
    643698 
    644699!!gm : mask is not required on forcing 
    645       DO jl = 1, ijpl 
    646          p_qns (:,:,jl) = p_qns (:,:,jl) * tmask(:,:,1) 
    647          p_qla (:,:,jl) = p_qla (:,:,jl) * tmask(:,:,1) 
    648          p_dqns(:,:,jl) = p_dqns(:,:,jl) * tmask(:,:,1) 
    649          p_dqla(:,:,jl) = p_dqla(:,:,jl) * tmask(:,:,1) 
    650       END DO 
     700      DO jl = 1, jpl 
     701         qns_ice (:,:,jl) = qns_ice (:,:,jl) * tmask(:,:,1) 
     702         qla_ice (:,:,jl) = qla_ice (:,:,jl) * tmask(:,:,1) 
     703         dqns_ice(:,:,jl) = dqns_ice(:,:,jl) * tmask(:,:,1) 
     704         dqla_ice(:,:,jl) = dqla_ice(:,:,jl) * tmask(:,:,1) 
     705      END DO 
     706 
     707      CALL wrk_dealloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 
     708      CALL wrk_dealloc( jpi,jpj, jpl  , z_qlw, z_qsb ) 
    651709 
    652710      IF(ln_ctl) THEN 
    653          CALL prt_ctl(tab3d_1=z_qsb  , clinfo1=' blk_ice_clio: z_qsb  : ', tab3d_2=z_qlw  , clinfo2=' z_qlw  : ', kdim=ijpl) 
    654          CALL prt_ctl(tab3d_1=p_qla  , clinfo1=' blk_ice_clio: z_qla  : ', tab3d_2=p_qsr  , clinfo2=' p_qsr  : ', kdim=ijpl) 
    655          CALL prt_ctl(tab3d_1=p_dqns , clinfo1=' blk_ice_clio: p_dqns : ', tab3d_2=p_qns  , clinfo2=' p_qns  : ', kdim=ijpl) 
    656          CALL prt_ctl(tab3d_1=p_dqla , clinfo1=' blk_ice_clio: p_dqla : ', tab3d_2=pst    , clinfo2=' pst    : ', kdim=ijpl) 
    657          CALL prt_ctl(tab2d_1=p_tpr  , clinfo1=' blk_ice_clio: p_tpr  : ', tab2d_2=p_spr  , clinfo2=' p_spr  : ') 
    658          CALL prt_ctl(tab2d_1=p_taui , clinfo1=' blk_ice_clio: p_taui : ', tab2d_2=p_tauj , clinfo2=' p_tauj : ') 
     711         CALL prt_ctl(tab3d_1=z_qsb  , clinfo1=' blk_ice_clio: z_qsb  : ', tab3d_2=z_qlw  , clinfo2=' z_qlw  : ', kdim=jpl) 
     712         CALL prt_ctl(tab3d_1=qla_ice  , clinfo1=' blk_ice_clio: z_qla  : ', tab3d_2=qsr_ice  , clinfo2=' qsr_ice  : ', kdim=jpl) 
     713         CALL prt_ctl(tab3d_1=dqns_ice , clinfo1=' blk_ice_clio: dqns_ice : ', tab3d_2=qns_ice  , clinfo2=' qns_ice  : ', kdim=jpl) 
     714         CALL prt_ctl(tab3d_1=dqla_ice , clinfo1=' blk_ice_clio: dqla_ice : ', tab3d_2=ptsu    , clinfo2=' ptsu    : ', kdim=jpl) 
     715         CALL prt_ctl(tab2d_1=tprecip  , clinfo1=' blk_ice_clio: tprecip  : ', tab2d_2=sprecip  , clinfo2=' sprecip  : ') 
    659716      ENDIF 
    660717 
    661       CALL wrk_dealloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 
    662       CALL wrk_dealloc( jpi,jpj,pdim, z_qlw, z_qsb ) 
    663       ! 
    664       IF( nn_timing == 1 )  CALL timing_stop('blk_ice_clio') 
    665       ! 
    666    END SUBROUTINE blk_ice_clio 
    667  
     718      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_clio_flx') 
     719      ! 
     720   END SUBROUTINE blk_ice_clio_flx 
     721 
     722#endif 
    668723 
    669724   SUBROUTINE blk_clio_qsr_oce( pqsr_oce ) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r5038 r5620  
    2222   !!   blk_oce_core    : computes momentum, heat and freshwater fluxes over ocean 
    2323   !!   blk_ice_core    : computes momentum, heat and freshwater fluxes over ice 
    24    !!   blk_bio_meanqsr : compute daily mean short wave radiation over the ocean 
    25    !!   blk_ice_meanqsr : compute daily mean short wave radiation over the ice 
    2624   !!   turb_core_2z    : Computes turbulent transfert coefficients 
    2725   !!   cd_neutral_10m  : Estimate of the neutral drag coefficient at 10m 
     
    4644   USE sbc_ice         ! Surface boundary condition: ice fields 
    4745   USE lib_fortran     ! to use key_nosignedzero 
     46#if defined key_lim3 
     47   USE ice, ONLY       : u_ice, v_ice, jpl, pfrld, a_i_b 
     48   USE limthd_dh       ! for CALL lim_thd_snwblow 
     49#elif defined key_lim2 
     50   USE ice_2, ONLY     : u_ice, v_ice 
     51   USE par_ice_2 
     52#endif 
    4853 
    4954   IMPLICIT NONE 
     
    5156 
    5257   PUBLIC   sbc_blk_core         ! routine called in sbcmod module 
    53    PUBLIC   blk_ice_core         ! routine called in sbc_ice_lim module 
    54    PUBLIC   blk_ice_meanqsr      ! routine called in sbc_ice_lim module 
     58#if defined key_lim2 || defined key_lim3 
     59   PUBLIC   blk_ice_core_tau     ! routine called in sbc_ice_lim module 
     60   PUBLIC   blk_ice_core_flx     ! routine called in sbc_ice_lim module 
     61#endif 
    5562   PUBLIC   turb_core_2z         ! routine calles in sbcblk_mfs module 
    5663 
     
    195202      !                                            ! compute the surface ocean fluxes using CORE bulk formulea 
    196203      IF( MOD( kt - 1, nn_fsbc ) == 0 )   CALL blk_oce_core( kt, sf, sst_m, ssu_m, ssv_m ) 
    197  
    198       ! If diurnal cycle is activated, compute a daily mean short waves flux for biogeochemistery 
    199       IF( ltrcdm2dc )   CALL blk_bio_meanqsr 
    200204 
    201205#if defined key_cice 
     
    302306      ELSE                  ;   qsr(:,:) = zztmp *          sf(jp_qsr)%fnow(:,:,1)   * tmask(:,:,1) 
    303307      ENDIF 
     308 
    304309      zqlw(:,:) = (  sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:)  ) * tmask(:,:,1)   ! Long  Wave 
    305310      ! ----------------------------------------------------------------------------- ! 
     
    376381      emp (:,:) = (  zevap(:,:)                                          &   ! mass flux (evap. - precip.) 
    377382         &         - sf(jp_prec)%fnow(:,:,1) * rn_pfac  ) * tmask(:,:,1) 
    378       qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)                                &   ! Downward Non Solar flux 
     383      ! 
     384      qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)                                &   ! Downward Non Solar  
    379385         &     - sf(jp_snow)%fnow(:,:,1) * rn_pfac * lfus                         &   ! remove latent melting heat for solid precip 
    380386         &     - zevap(:,:) * pst(:,:) * rcp                                      &   ! remove evap heat content at SST 
     
    384390         &     * ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) 
    385391      ! 
    386       CALL iom_put( "qlw_oce",   zqlw )                 ! output downward longwave heat over the ocean 
    387       CALL iom_put( "qsb_oce", - zqsb )                 ! output downward sensible heat over the ocean 
    388       CALL iom_put( "qla_oce", - zqla )                 ! output downward latent   heat over the ocean 
    389       CALL iom_put( "qhc_oce",   qns-zqlw+zqsb+zqla )   ! output downward heat content of E-P over the ocean 
    390       CALL iom_put( "qns_oce",   qns  )                 ! output downward non solar heat over the ocean 
     392#if defined key_lim3 
     393      qns_oce(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)                                ! non solar without emp (only needed by LIM3) 
     394      qsr_oce(:,:) = qsr(:,:) 
     395#endif 
     396      ! 
     397      IF ( nn_ice == 0 ) THEN 
     398         CALL iom_put( "qlw_oce" ,   zqlw )                 ! output downward longwave heat over the ocean 
     399         CALL iom_put( "qsb_oce" , - zqsb )                 ! output downward sensible heat over the ocean 
     400         CALL iom_put( "qla_oce" , - zqla )                 ! output downward latent   heat over the ocean 
     401         CALL iom_put( "qemp_oce",   qns-zqlw+zqsb+zqla )   ! output downward heat content of E-P over the ocean 
     402         CALL iom_put( "qns_oce" ,   qns  )                 ! output downward non solar heat over the ocean 
     403         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean 
     404         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean 
     405         tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac   ! output total precipitation [kg/m2/s] 
     406         sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac   ! output solid precipitation [kg/m2/s] 
     407         CALL iom_put( 'snowpre', sprecip * 86400. )        ! Snow 
     408         CALL iom_put( 'precip' , tprecip * 86400. )        ! Total precipitation 
     409      ENDIF 
    391410      ! 
    392411      IF(ln_ctl) THEN 
     
    406425  
    407426    
    408    SUBROUTINE blk_ice_core(  pst   , pui   , pvi   , palb ,   & 
    409       &                      p_taui, p_tauj, p_qns , p_qsr,   & 
    410       &                      p_qla , p_dqns, p_dqla,          & 
    411       &                      p_tpr , p_spr ,                  & 
    412       &                      p_fr1 , p_fr2 , cd_grid, pdim  )  
    413       !!--------------------------------------------------------------------- 
    414       !!                     ***  ROUTINE blk_ice_core  *** 
     427#if defined key_lim2 || defined key_lim3 
     428   SUBROUTINE blk_ice_core_tau 
     429      !!--------------------------------------------------------------------- 
     430      !!                     ***  ROUTINE blk_ice_core_tau  *** 
    415431      !! 
    416432      !! ** Purpose :   provide the surface boundary condition over sea-ice 
    417433      !! 
    418       !! ** Method  :   compute momentum, heat and freshwater exchanged 
    419       !!                between atmosphere and sea-ice using CORE bulk 
    420       !!                formulea, ice variables and read atmmospheric fields. 
     434      !! ** Method  :   compute momentum using CORE bulk 
     435      !!                formulea, ice variables and read atmospheric fields. 
    421436      !!                NB: ice drag coefficient is assumed to be a constant 
    422       !!  
    423       !! caution : the net upward water flux has with mm/day unit 
    424       !!--------------------------------------------------------------------- 
    425       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pst      ! ice surface temperature (>0, =rt0 over land) [Kelvin] 
    426       REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pui      ! ice surface velocity (i- and i- components      [m/s] 
    427       REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pvi      !    at I-point (B-grid) or U & V-point (C-grid) 
    428       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   palb     ! ice albedo (all skies)                            [%] 
    429       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_taui   ! i- & j-components of surface ice stress        [N/m2] 
    430       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_tauj   !   at I-point (B-grid) or U & V-point (C-grid) 
    431       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_qns    ! non solar heat flux over ice (T-point)         [W/m2] 
    432       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_qsr    !     solar heat flux over ice (T-point)         [W/m2] 
    433       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_qla    ! latent    heat flux over ice (T-point)         [W/m2] 
    434       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_dqns   ! non solar heat sensistivity  (T-point)         [W/m2] 
    435       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_dqla   ! latent    heat sensistivity  (T-point)         [W/m2] 
    436       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_tpr    ! total precipitation          (T-point)      [Kg/m2/s] 
    437       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_spr    ! solid precipitation          (T-point)      [Kg/m2/s] 
    438       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_fr1    ! 1sr fraction of qsr penetration in ice (T-point)  [%] 
    439       REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   p_fr2    ! 2nd fraction of qsr penetration in ice (T-point)  [%] 
    440       CHARACTER(len=1)          , INTENT(in   ) ::   cd_grid  ! ice grid ( C or B-grid) 
    441       INTEGER                   , INTENT(in   ) ::   pdim     ! number of ice categories 
    442       !! 
    443       INTEGER  ::   ji, jj, jl    ! dummy loop indices 
    444       INTEGER  ::   ijpl          ! number of ice categories (size of 3rd dim of input arrays) 
    445       REAL(wp) ::   zst2, zst3 
    446       REAL(wp) ::   zcoef_wnorm, zcoef_wnorm2, zcoef_dqlw, zcoef_dqla, zcoef_dqsb 
    447       REAL(wp) ::   zztmp                                        ! temporary variable 
    448       REAL(wp) ::   zwnorm_f, zwndi_f , zwndj_f                  ! relative wind module and components at F-point 
    449       REAL(wp) ::             zwndi_t , zwndj_t                  ! relative wind components at T-point 
    450       !! 
    451       REAL(wp), DIMENSION(:,:)  , POINTER ::   z_wnds_t          ! wind speed ( = | U10m - U_ice | ) at T-point 
    452       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw             ! long wave heat flux over ice 
    453       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qsb             ! sensible  heat flux over ice 
    454       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqlw            ! long wave heat sensitivity over ice 
    455       REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqsb            ! sensible  heat sensitivity over ice 
    456       !!--------------------------------------------------------------------- 
    457       ! 
    458       IF( nn_timing == 1 )  CALL timing_start('blk_ice_core') 
    459       ! 
    460       CALL wrk_alloc( jpi,jpj, z_wnds_t ) 
    461       CALL wrk_alloc( jpi,jpj,pdim, z_qlw, z_qsb, z_dqlw, z_dqsb )  
    462  
    463       ijpl  = pdim                            ! number of ice categories 
    464  
     437      !!--------------------------------------------------------------------- 
     438      INTEGER  ::   ji, jj    ! dummy loop indices 
     439      REAL(wp) ::   zcoef_wnorm, zcoef_wnorm2 
     440      REAL(wp) ::   zwnorm_f, zwndi_f , zwndj_f               ! relative wind module and components at F-point 
     441      REAL(wp) ::             zwndi_t , zwndj_t               ! relative wind components at T-point 
     442      !!--------------------------------------------------------------------- 
     443      ! 
     444      IF( nn_timing == 1 )  CALL timing_start('blk_ice_core_tau') 
     445      ! 
    465446      ! local scalars ( place there for vector optimisation purposes) 
    466447      zcoef_wnorm  = rhoa * Cice 
    467448      zcoef_wnorm2 = rhoa * Cice * 0.5 
    468       zcoef_dqlw   = 4.0 * 0.95 * Stef 
    469       zcoef_dqla   = -Ls * Cice * 11637800. * (-5897.8) 
    470       zcoef_dqsb   = rhoa * cpa * Cice 
    471449 
    472450!!gm brutal.... 
    473       z_wnds_t(:,:) = 0.e0 
    474       p_taui  (:,:) = 0.e0 
    475       p_tauj  (:,:) = 0.e0 
     451      utau_ice  (:,:) = 0._wp 
     452      vtau_ice  (:,:) = 0._wp 
     453      wndm_ice  (:,:) = 0._wp 
    476454!!gm end 
    477455 
    478 #if defined key_lim3 
    479       tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1)   ! LIM3: make Tair available in sea-ice. WARNING allocated after call to ice_init 
    480 #endif 
    481456      ! ----------------------------------------------------------------------------- ! 
    482457      !    Wind components and module relative to the moving ocean ( U10m - U_ice )   ! 
    483458      ! ----------------------------------------------------------------------------- ! 
    484       SELECT CASE( cd_grid ) 
     459      SELECT CASE( cp_ice_msh ) 
    485460      CASE( 'I' )                  ! B-grid ice dynamics :   I-point (i.e. F-point with sea-ice indexation) 
    486461         !                           and scalar wind at T-point ( = | U10m - U_ice | ) (masked) 
     
    489464               ! ... scalar wind at I-point (fld being at T-point) 
    490465               zwndi_f = 0.25 * (  sf(jp_wndi)%fnow(ji-1,jj  ,1) + sf(jp_wndi)%fnow(ji  ,jj  ,1)   & 
    491                   &              + sf(jp_wndi)%fnow(ji-1,jj-1,1) + sf(jp_wndi)%fnow(ji  ,jj-1,1)  ) - rn_vfac * pui(ji,jj) 
     466                  &              + sf(jp_wndi)%fnow(ji-1,jj-1,1) + sf(jp_wndi)%fnow(ji  ,jj-1,1)  ) - rn_vfac * u_ice(ji,jj) 
    492467               zwndj_f = 0.25 * (  sf(jp_wndj)%fnow(ji-1,jj  ,1) + sf(jp_wndj)%fnow(ji  ,jj  ,1)   & 
    493                   &              + sf(jp_wndj)%fnow(ji-1,jj-1,1) + sf(jp_wndj)%fnow(ji  ,jj-1,1)  ) - rn_vfac * pvi(ji,jj) 
     468                  &              + sf(jp_wndj)%fnow(ji-1,jj-1,1) + sf(jp_wndj)%fnow(ji  ,jj-1,1)  ) - rn_vfac * v_ice(ji,jj) 
    494469               zwnorm_f = zcoef_wnorm * SQRT( zwndi_f * zwndi_f + zwndj_f * zwndj_f ) 
    495470               ! ... ice stress at I-point 
    496                p_taui(ji,jj) = zwnorm_f * zwndi_f 
    497                p_tauj(ji,jj) = zwnorm_f * zwndj_f 
     471               utau_ice(ji,jj) = zwnorm_f * zwndi_f 
     472               vtau_ice(ji,jj) = zwnorm_f * zwndj_f 
    498473               ! ... scalar wind at T-point (fld being at T-point) 
    499                zwndi_t = sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  pui(ji,jj+1) + pui(ji+1,jj+1)   & 
    500                   &                                                    + pui(ji,jj  ) + pui(ji+1,jj  )  ) 
    501                zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  pvi(ji,jj+1) + pvi(ji+1,jj+1)   & 
    502                   &                                                    + pvi(ji,jj  ) + pvi(ji+1,jj  )  ) 
    503                z_wnds_t(ji,jj)  = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
     474               zwndi_t = sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  u_ice(ji,jj+1) + u_ice(ji+1,jj+1)   & 
     475                  &                                                    + u_ice(ji,jj  ) + u_ice(ji+1,jj  )  ) 
     476               zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  v_ice(ji,jj+1) + v_ice(ji+1,jj+1)   & 
     477                  &                                                    + v_ice(ji,jj  ) + v_ice(ji+1,jj  )  ) 
     478               wndm_ice(ji,jj)  = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
    504479            END DO 
    505480         END DO 
    506          CALL lbc_lnk( p_taui  , 'I', -1. ) 
    507          CALL lbc_lnk( p_tauj  , 'I', -1. ) 
    508          CALL lbc_lnk( z_wnds_t, 'T',  1. ) 
     481         CALL lbc_lnk( utau_ice, 'I', -1. ) 
     482         CALL lbc_lnk( vtau_ice, 'I', -1. ) 
     483         CALL lbc_lnk( wndm_ice, 'T',  1. ) 
    509484         ! 
    510485      CASE( 'C' )                  ! C-grid ice dynamics :   U & V-points (same as ocean) 
    511486         DO jj = 2, jpj 
    512487            DO ji = fs_2, jpi   ! vect. opt. 
    513                zwndi_t = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pui(ji-1,jj  ) + pui(ji,jj) )  ) 
    514                zwndj_t = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pvi(ji  ,jj-1) + pvi(ji,jj) )  ) 
    515                z_wnds_t(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
     488               zwndi_t = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj  ) + u_ice(ji,jj) )  ) 
     489               zwndj_t = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji  ,jj-1) + v_ice(ji,jj) )  ) 
     490               wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
    516491            END DO 
    517492         END DO 
    518493         DO jj = 2, jpjm1 
    519494            DO ji = fs_2, fs_jpim1   ! vect. opt. 
    520                p_taui(ji,jj) = zcoef_wnorm2 * ( z_wnds_t(ji+1,jj  ) + z_wnds_t(ji,jj) )                          & 
    521                   &          * ( 0.5 * (sf(jp_wndi)%fnow(ji+1,jj,1) + sf(jp_wndi)%fnow(ji,jj,1) ) - rn_vfac * pui(ji,jj) ) 
    522                p_tauj(ji,jj) = zcoef_wnorm2 * ( z_wnds_t(ji,jj+1  ) + z_wnds_t(ji,jj) )                          & 
    523                   &          * ( 0.5 * (sf(jp_wndj)%fnow(ji,jj+1,1) + sf(jp_wndj)%fnow(ji,jj,1) ) - rn_vfac * pvi(ji,jj) ) 
     495               utau_ice(ji,jj) = zcoef_wnorm2 * ( wndm_ice(ji+1,jj  ) + wndm_ice(ji,jj) )                          & 
     496                  &          * ( 0.5 * (sf(jp_wndi)%fnow(ji+1,jj,1) + sf(jp_wndi)%fnow(ji,jj,1) ) - rn_vfac * u_ice(ji,jj) ) 
     497               vtau_ice(ji,jj) = zcoef_wnorm2 * ( wndm_ice(ji,jj+1  ) + wndm_ice(ji,jj) )                          & 
     498                  &          * ( 0.5 * (sf(jp_wndj)%fnow(ji,jj+1,1) + sf(jp_wndj)%fnow(ji,jj,1) ) - rn_vfac * v_ice(ji,jj) ) 
    524499            END DO 
    525500         END DO 
    526          CALL lbc_lnk( p_taui  , 'U', -1. ) 
    527          CALL lbc_lnk( p_tauj  , 'V', -1. ) 
    528          CALL lbc_lnk( z_wnds_t, 'T',  1. ) 
     501         CALL lbc_lnk( utau_ice, 'U', -1. ) 
     502         CALL lbc_lnk( vtau_ice, 'V', -1. ) 
     503         CALL lbc_lnk( wndm_ice, 'T',  1. ) 
    529504         ! 
    530505      END SELECT 
     506 
     507      IF(ln_ctl) THEN 
     508         CALL prt_ctl(tab2d_1=utau_ice  , clinfo1=' blk_ice_core: utau_ice : ', tab2d_2=vtau_ice  , clinfo2=' vtau_ice : ') 
     509         CALL prt_ctl(tab2d_1=wndm_ice  , clinfo1=' blk_ice_core: wndm_ice : ') 
     510      ENDIF 
     511 
     512      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_core_tau') 
     513       
     514   END SUBROUTINE blk_ice_core_tau 
     515 
     516 
     517   SUBROUTINE blk_ice_core_flx( ptsu, palb ) 
     518      !!--------------------------------------------------------------------- 
     519      !!                     ***  ROUTINE blk_ice_core_flx  *** 
     520      !! 
     521      !! ** Purpose :   provide the surface boundary condition over sea-ice 
     522      !! 
     523      !! ** Method  :   compute heat and freshwater exchanged 
     524      !!                between atmosphere and sea-ice using CORE bulk 
     525      !!                formulea, ice variables and read atmmospheric fields. 
     526      !!  
     527      !! caution : the net upward water flux has with mm/day unit 
     528      !!--------------------------------------------------------------------- 
     529      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   ptsu          ! sea ice surface temperature 
     530      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   palb          ! ice albedo (all skies) 
     531      !! 
     532      INTEGER  ::   ji, jj, jl    ! dummy loop indices 
     533      REAL(wp) ::   zst2, zst3 
     534      REAL(wp) ::   zcoef_dqlw, zcoef_dqla, zcoef_dqsb 
     535      REAL(wp) ::   zztmp, z1_lsub                               ! temporary variable 
     536      !! 
     537      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw             ! long wave heat flux over ice 
     538      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qsb             ! sensible  heat flux over ice 
     539      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqlw            ! long wave heat sensitivity over ice 
     540      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqsb            ! sensible  heat sensitivity over ice 
     541      REAL(wp), DIMENSION(:,:)  , POINTER ::   zevap, zsnw       ! evaporation and snw distribution after wind blowing (LIM3) 
     542      !!--------------------------------------------------------------------- 
     543      ! 
     544      IF( nn_timing == 1 )  CALL timing_start('blk_ice_core_flx') 
     545      ! 
     546      CALL wrk_alloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb )  
     547 
     548      ! local scalars ( place there for vector optimisation purposes) 
     549      zcoef_dqlw   = 4.0 * 0.95 * Stef 
     550      zcoef_dqla   = -Ls * Cice * 11637800. * (-5897.8) 
     551      zcoef_dqsb   = rhoa * cpa * Cice 
    531552 
    532553      zztmp = 1. / ( 1. - albo ) 
    533554      !                                     ! ========================== ! 
    534       DO jl = 1, ijpl                       !  Loop over ice categories  ! 
     555      DO jl = 1, jpl                        !  Loop over ice categories  ! 
    535556         !                                  ! ========================== ! 
    536557         DO jj = 1 , jpj 
     
    539560               !      I   Radiative FLUXES   ! 
    540561               ! ----------------------------! 
    541                zst2 = pst(ji,jj,jl) * pst(ji,jj,jl) 
    542                zst3 = pst(ji,jj,jl) * zst2 
     562               zst2 = ptsu(ji,jj,jl) * ptsu(ji,jj,jl) 
     563               zst3 = ptsu(ji,jj,jl) * zst2 
    543564               ! Short Wave (sw) 
    544                p_qsr(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) 
     565               qsr_ice(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) 
    545566               ! Long  Wave (lw) 
    546                z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * pst(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) 
     567               z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * ptsu(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) 
    547568               ! lw sensitivity 
    548569               z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3                                                
     
    554575               ! ... turbulent heat fluxes 
    555576               ! Sensible Heat 
    556                z_qsb(ji,jj,jl) = rhoa * cpa * Cice * z_wnds_t(ji,jj) * ( pst(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1) ) 
     577               z_qsb(ji,jj,jl) = rhoa * cpa * Cice * wndm_ice(ji,jj) * ( ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1) ) 
    557578               ! Latent Heat 
    558                p_qla(ji,jj,jl) = rn_efac * MAX( 0.e0, rhoa * Ls  * Cice * z_wnds_t(ji,jj)   &                            
    559                   &                         * (  11637800. * EXP( -5897.8 / pst(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1)  ) ) 
    560                ! Latent heat sensitivity for ice (Dqla/Dt) 
    561                IF( p_qla(ji,jj,jl) > 0._wp ) THEN 
    562                   p_dqla(ji,jj,jl) = rn_efac * zcoef_dqla * z_wnds_t(ji,jj) / ( zst2 ) * EXP( -5897.8 / pst(ji,jj,jl) ) 
     579               qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, rhoa * Ls  * Cice * wndm_ice(ji,jj)   &                            
     580                  &                         * (  11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1)  ) ) 
     581              ! Latent heat sensitivity for ice (Dqla/Dt) 
     582               IF( qla_ice(ji,jj,jl) > 0._wp ) THEN 
     583                  dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * wndm_ice(ji,jj) / ( zst2 ) * EXP( -5897.8 / ptsu(ji,jj,jl) ) 
    563584               ELSE 
    564                   p_dqla(ji,jj,jl) = 0._wp 
     585                  dqla_ice(ji,jj,jl) = 0._wp 
    565586               ENDIF 
    566587 
    567588               ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice) 
    568                z_dqsb(ji,jj,jl) = zcoef_dqsb * z_wnds_t(ji,jj) 
     589               z_dqsb(ji,jj,jl) = zcoef_dqsb * wndm_ice(ji,jj) 
    569590 
    570591               ! ----------------------------! 
     
    572593               ! ----------------------------! 
    573594               ! Downward Non Solar flux 
    574                p_qns (ji,jj,jl) =     z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - p_qla (ji,jj,jl) 
     595               qns_ice (ji,jj,jl) =     z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - qla_ice (ji,jj,jl) 
    575596               ! Total non solar heat flux sensitivity for ice 
    576                p_dqns(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + p_dqla(ji,jj,jl) ) 
     597               dqns_ice(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + dqla_ice(ji,jj,jl) ) 
    577598            END DO 
    578599            ! 
     
    581602      END DO 
    582603      ! 
     604      tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac      ! total precipitation [kg/m2/s] 
     605      sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac      ! solid precipitation [kg/m2/s] 
     606      CALL iom_put( 'snowpre', sprecip * 86400. )                  ! Snow precipitation 
     607      CALL iom_put( 'precip' , tprecip * 86400. )                  ! Total precipitation 
     608 
     609#if defined  key_lim3 
     610      CALL wrk_alloc( jpi,jpj, zevap, zsnw )  
     611 
     612      ! --- evaporation --- ! 
     613      z1_lsub = 1._wp / Lsub 
     614      evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
     615      devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
     616      zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
     617 
     618      ! --- evaporation minus precipitation --- ! 
     619      zsnw(:,:) = 0._wp 
     620      CALL lim_thd_snwblow( pfrld, zsnw )  ! snow distribution over ice after wind blowing  
     621      emp_oce(:,:) = pfrld(:,:) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) 
     622      emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw 
     623      emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) 
     624 
     625      ! --- heat flux associated with emp --- ! 
     626      qemp_oce(:,:) = - pfrld(:,:) * zevap(:,:) * sst_m(:,:) * rcp                               & ! evap at sst 
     627         &          + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp  & ! liquid precip at Tair 
     628         &          +   sprecip(:,:) * ( 1._wp - zsnw ) *                                        & ! solid precip at min(Tair,Tsnow) 
     629         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     630      qemp_ice(:,:) =   sprecip(:,:) * zsnw *                                                    & ! solid precip (only) 
     631         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     632 
     633      ! --- total solar and non solar fluxes --- ! 
     634      qns_tot(:,:) = pfrld(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) 
     635      qsr_tot(:,:) = pfrld(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) 
     636 
     637      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     638      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     639 
     640      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
     641#endif 
     642 
    583643      !-------------------------------------------------------------------- 
    584644      ! FRACTIONs of net shortwave radiation which is not absorbed in the 
     
    586646      ! ( Maykut and Untersteiner, 1971 ; Ebert and Curry, 1993 ) 
    587647      ! 
    588       p_fr1(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 
    589       p_fr2(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    590       ! 
    591       p_tpr(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac      ! total precipitation [kg/m2/s] 
    592       p_spr(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac      ! solid precipitation [kg/m2/s] 
    593       CALL iom_put( 'snowpre', p_spr * 86400. )                  ! Snow precipitation 
    594       CALL iom_put( 'precip' , p_tpr * 86400. )                  ! Total precipitation 
     648      fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 
     649      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
     650      ! 
    595651      ! 
    596652      IF(ln_ctl) THEN 
    597          CALL prt_ctl(tab3d_1=p_qla   , clinfo1=' blk_ice_core: p_qla  : ', tab3d_2=z_qsb   , clinfo2=' z_qsb  : ', kdim=ijpl) 
    598          CALL prt_ctl(tab3d_1=z_qlw   , clinfo1=' blk_ice_core: z_qlw  : ', tab3d_2=p_dqla  , clinfo2=' p_dqla : ', kdim=ijpl) 
    599          CALL prt_ctl(tab3d_1=z_dqsb  , clinfo1=' blk_ice_core: z_dqsb : ', tab3d_2=z_dqlw  , clinfo2=' z_dqlw : ', kdim=ijpl) 
    600          CALL prt_ctl(tab3d_1=p_dqns  , clinfo1=' blk_ice_core: p_dqns : ', tab3d_2=p_qsr   , clinfo2=' p_qsr  : ', kdim=ijpl) 
    601          CALL prt_ctl(tab3d_1=pst     , clinfo1=' blk_ice_core: pst    : ', tab3d_2=p_qns   , clinfo2=' p_qns  : ', kdim=ijpl) 
    602          CALL prt_ctl(tab2d_1=p_tpr   , clinfo1=' blk_ice_core: p_tpr  : ', tab2d_2=p_spr   , clinfo2=' p_spr  : ') 
    603          CALL prt_ctl(tab2d_1=p_taui  , clinfo1=' blk_ice_core: p_taui : ', tab2d_2=p_tauj  , clinfo2=' p_tauj : ') 
    604          CALL prt_ctl(tab2d_1=z_wnds_t, clinfo1=' blk_ice_core: z_wnds_t : ') 
    605       ENDIF 
    606  
    607       CALL wrk_dealloc( jpi,jpj,   z_wnds_t ) 
    608       CALL wrk_dealloc( jpi,jpj,   pdim, z_qlw, z_qsb, z_dqlw, z_dqsb ) 
    609       ! 
    610       IF( nn_timing == 1 )  CALL timing_stop('blk_ice_core') 
    611       ! 
    612    END SUBROUTINE blk_ice_core 
    613  
    614  
    615    SUBROUTINE blk_bio_meanqsr 
    616       !!--------------------------------------------------------------------- 
    617       !!                     ***  ROUTINE blk_bio_meanqsr 
    618       !!                      
    619       !! ** Purpose :   provide daily qsr_mean for PISCES when 
    620       !!                analytic diurnal cycle is applied in physic 
    621       !!                 
    622       !! ** Method  :   add part where there is no ice 
    623       !!  
    624       !!--------------------------------------------------------------------- 
    625       IF( nn_timing == 1 )  CALL timing_start('blk_bio_meanqsr') 
    626       ! 
    627       qsr_mean(:,:) = (1. - albo ) *  sf(jp_qsr)%fnow(:,:,1) 
    628       ! 
    629       IF( nn_timing == 1 )  CALL timing_stop('blk_bio_meanqsr') 
    630       ! 
    631    END SUBROUTINE blk_bio_meanqsr 
    632   
    633   
    634    SUBROUTINE blk_ice_meanqsr( palb, p_qsr_mean, pdim ) 
    635       !!--------------------------------------------------------------------- 
    636       !! 
    637       !! ** Purpose :   provide the daily qsr_mean over sea_ice for PISCES when 
    638       !!                analytic diurnal cycle is applied in physic 
    639       !! 
    640       !! ** Method  :   compute qsr 
    641       !!  
    642       !!--------------------------------------------------------------------- 
    643       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   palb       ! ice albedo (clear sky) (alb_ice_cs)               [%] 
    644       REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_qsr_mean !     solar heat flux over ice (T-point)         [W/m2] 
    645       INTEGER                   , INTENT(in   ) ::   pdim       ! number of ice categories 
    646       ! 
    647       INTEGER  ::   ijpl          ! number of ice categories (size of 3rd dim of input arrays) 
    648       INTEGER  ::   ji, jj, jl    ! dummy loop indices 
    649       REAL(wp) ::   zztmp         ! temporary variable 
    650       !!--------------------------------------------------------------------- 
    651       IF( nn_timing == 1 )  CALL timing_start('blk_ice_meanqsr') 
    652       ! 
    653       ijpl  = pdim                            ! number of ice categories 
    654       zztmp = 1. / ( 1. - albo ) 
    655       !                                     ! ========================== ! 
    656       DO jl = 1, ijpl                       !  Loop over ice categories  ! 
    657          !                                  ! ========================== ! 
    658          DO jj = 1 , jpj 
    659             DO ji = 1, jpi 
    660                   p_qsr_mean(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr_mean(ji,jj) 
    661             END DO 
    662          END DO 
    663       END DO 
    664       ! 
    665       IF( nn_timing == 1 )  CALL timing_stop('blk_ice_meanqsr') 
    666       ! 
    667    END SUBROUTINE blk_ice_meanqsr   
    668  
     653         CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice_core: qla_ice  : ', tab3d_2=z_qsb   , clinfo2=' z_qsb    : ', kdim=jpl) 
     654         CALL prt_ctl(tab3d_1=z_qlw   , clinfo1=' blk_ice_core: z_qlw    : ', tab3d_2=dqla_ice, clinfo2=' dqla_ice : ', kdim=jpl) 
     655         CALL prt_ctl(tab3d_1=z_dqsb  , clinfo1=' blk_ice_core: z_dqsb   : ', tab3d_2=z_dqlw  , clinfo2=' z_dqlw   : ', kdim=jpl) 
     656         CALL prt_ctl(tab3d_1=dqns_ice, clinfo1=' blk_ice_core: dqns_ice : ', tab3d_2=qsr_ice , clinfo2=' qsr_ice  : ', kdim=jpl) 
     657         CALL prt_ctl(tab3d_1=ptsu    , clinfo1=' blk_ice_core: ptsu     : ', tab3d_2=qns_ice , clinfo2=' qns_ice  : ', kdim=jpl) 
     658         CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice_core: tprecip  : ', tab2d_2=sprecip , clinfo2=' sprecip  : ') 
     659      ENDIF 
     660 
     661      CALL wrk_dealloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb ) 
     662      ! 
     663      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_core_flx') 
     664       
     665   END SUBROUTINE blk_ice_core_flx 
     666#endif 
    669667 
    670668   SUBROUTINE turb_core_2z( zt, zu, sst, T_zt, q_sat, q_zt, dU,    & 
     
    848846      rgt33 = 0.5_wp + SIGN( 0.5_wp, (zw10 - 33._wp) )   ! If zw10 < 33. => 0, else => 1   
    849847      cd_neutral_10m = 1.e-3 * ( & 
    850          &       (rgt33 + 1._wp)*( 2.7_wp/zw10 + 0.142_wp + zw10/13.09_wp - 3.14807E-10*zw10**6) & ! zw10< 33. 
     848         &       (1._wp - rgt33)*( 2.7_wp/zw10 + 0.142_wp + zw10/13.09_wp - 3.14807E-10*zw10**6) & ! zw10< 33. 
    851849         &      + rgt33         *      2.34   )                                                    ! zw10 >= 33. 
    852850      ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_mfs.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    4646   !!---------------------------------------------------------------------- 
    4747   !! NEMO/OPA 3.2 , LOCEAN-IPSL (2009)  
    48    !! $Id: sbcblk_mfs.F90 1730 2009-11-16 14:34:19Z poddo $ 
     48   !! $Id$ 
    4949   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    5050   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r5038 r5620  
    2121   USE sbc_oce         ! Surface boundary condition: ocean fields 
    2222   USE sbc_ice         ! Surface boundary condition: ice fields 
     23   USE sbcapr 
    2324   USE sbcdcy          ! surface boundary condition: diurnal cycle 
    2425   USE phycst          ! physical constants 
    2526#if defined key_lim3 
    26    USE par_ice         ! ice parameters 
    2727   USE ice             ! ice variables 
    2828#endif 
     
    3333   USE cpl_oasis3      ! OASIS3 coupling 
    3434   USE geo2ocean       !  
    35    USE oce   , ONLY : tsn, un, vn 
     35   USE oce   , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev 
    3636   USE albedo          ! 
    3737   USE in_out_manager  ! I/O manager 
     
    4141   USE timing          ! Timing 
    4242   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     43   USE eosbn2 
     44   USE sbcrnf   , ONLY : l_rnfcpl 
    4345#if defined key_cpl_carbon_cycle 
    4446   USE p4zflx, ONLY : oce_co2 
     
    4749   USE ice_domain_size, only: ncat 
    4850#endif 
     51#if defined key_lim3 
     52   USE limthd_dh       ! for CALL lim_thd_snwblow 
     53#endif 
     54 
    4955   IMPLICIT NONE 
    5056   PRIVATE 
    51 !EM XIOS-OASIS-MCT compliance 
     57 
    5258   PUBLIC   sbc_cpl_init       ! routine called by sbcmod.F90 
    5359   PUBLIC   sbc_cpl_rcv        ! routine called by sbc_ice_lim(_2).F90 
     
    9096   INTEGER, PARAMETER ::   jpr_topm   = 32            ! topmeltn 
    9197   INTEGER, PARAMETER ::   jpr_botm   = 33            ! botmeltn 
    92    INTEGER, PARAMETER ::   jprcv      = 33            ! total number of fields received 
    93  
    94    INTEGER, PARAMETER ::   jps_fice   =  1            ! ice fraction  
     98   INTEGER, PARAMETER ::   jpr_sflx   = 34            ! salt flux 
     99   INTEGER, PARAMETER ::   jpr_toce   = 35            ! ocean temperature 
     100   INTEGER, PARAMETER ::   jpr_soce   = 36            ! ocean salinity 
     101   INTEGER, PARAMETER ::   jpr_ocx1   = 37            ! ocean current on grid 1 
     102   INTEGER, PARAMETER ::   jpr_ocy1   = 38            ! 
     103   INTEGER, PARAMETER ::   jpr_ssh    = 39            ! sea surface height 
     104   INTEGER, PARAMETER ::   jpr_fice   = 40            ! ice fraction           
     105   INTEGER, PARAMETER ::   jpr_e3t1st = 41            ! first T level thickness  
     106   INTEGER, PARAMETER ::   jpr_fraqsr = 42            ! fraction of solar net radiation absorbed in the first ocean level 
     107   INTEGER, PARAMETER ::   jprcv      = 42            ! total number of fields received 
     108 
     109   INTEGER, PARAMETER ::   jps_fice   =  1            ! ice fraction sent to the atmosphere 
    95110   INTEGER, PARAMETER ::   jps_toce   =  2            ! ocean temperature 
    96111   INTEGER, PARAMETER ::   jps_tice   =  3            ! ice   temperature 
     
    107122   INTEGER, PARAMETER ::   jps_ivz1   = 14            ! 
    108123   INTEGER, PARAMETER ::   jps_co2    = 15 
    109    INTEGER, PARAMETER ::   jpsnd      = 15            ! total number of fields sended 
     124   INTEGER, PARAMETER ::   jps_soce   = 16            ! ocean salinity 
     125   INTEGER, PARAMETER ::   jps_ssh    = 17            ! sea surface height 
     126   INTEGER, PARAMETER ::   jps_qsroce = 18            ! Qsr above the ocean 
     127   INTEGER, PARAMETER ::   jps_qnsoce = 19            ! Qns above the ocean 
     128   INTEGER, PARAMETER ::   jps_oemp   = 20            ! ocean freshwater budget (evap - precip) 
     129   INTEGER, PARAMETER ::   jps_sflx   = 21            ! salt flux 
     130   INTEGER, PARAMETER ::   jps_otx1   = 22            ! 2 atmosphere-ocean stress components on grid 1 
     131   INTEGER, PARAMETER ::   jps_oty1   = 23            !  
     132   INTEGER, PARAMETER ::   jps_rnf    = 24            ! runoffs 
     133   INTEGER, PARAMETER ::   jps_taum   = 25            ! wind stress module 
     134   INTEGER, PARAMETER ::   jps_fice2  = 26            ! ice fraction sent to OPA (by SAS when doing SAS-OPA coupling) 
     135   INTEGER, PARAMETER ::   jps_e3t1st = 27            ! first level depth (vvl) 
     136   INTEGER, PARAMETER ::   jps_fraqsr = 28            ! fraction of solar net radiation absorbed in the first ocean level 
     137   INTEGER, PARAMETER ::   jpsnd      = 28            ! total number of fields sended 
    110138 
    111139   !                                                         !!** namelist namsbc_cpl ** 
     
    126154   LOGICAL     ::   ln_usecplmask          !  use a coupling mask file to merge data received from several models 
    127155                                           !   -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) 
    128  
    129    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: xcplmask 
    130  
    131156   TYPE ::   DYNARR      
    132157      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   z3    
     
    140165 
    141166   !! Substitution 
     167#  include "domzgr_substitute.h90" 
    142168#  include "vectopt_loop_substitute.h90" 
    143169   !!---------------------------------------------------------------------- 
     
    162188      ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) )  ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) 
    163189#endif 
    164       ALLOCATE( xcplmask(jpi,jpj,nn_cplmodel) , STAT=ierr(3) ) 
     190      ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) 
    165191      ! 
    166192      sbc_cpl_alloc = MAXVAL( ierr ) 
     
    183209      !!              * initialise the OASIS coupler 
    184210      !!---------------------------------------------------------------------- 
    185       INTEGER, INTENT(in) ::   k_ice    ! ice management in the sbc (=0/1/2/3) 
     211      INTEGER, INTENT(in) ::   k_ice       ! ice management in the sbc (=0/1/2/3) 
    186212      !! 
    187213      INTEGER ::   jn   ! dummy loop index 
     
    217243         WRITE(numout,*)'sbc_cpl_init : namsbc_cpl namelist ' 
    218244         WRITE(numout,*)'~~~~~~~~~~~~' 
     245      ENDIF 
     246      IF( lwp .AND. ln_cpl ) THEN                        ! control print 
    219247         WRITE(numout,*)'  received fields (mutiple ice categogies)' 
    220248         WRITE(numout,*)'      10m wind module                 = ', TRIM(sn_rcv_w10m%cldes  ), ' (', TRIM(sn_rcv_w10m%clcat  ), ')' 
     
    360388      srcv(jpr_oemp)%clname = 'OOEvaMPr'      ! ocean water budget = ocean Evap - ocean precip 
    361389      SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 
     390      CASE( 'none'          )       ! nothing to do 
    362391      CASE( 'oce only'      )   ;   srcv(                                 jpr_oemp   )%laction = .TRUE.  
    363392      CASE( 'conservative'  ) 
     
    371400      !                                                      !     Runoffs & Calving     !    
    372401      !                                                      ! ------------------------- ! 
    373       srcv(jpr_rnf   )%clname = 'O_Runoff'   ;   IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' )   srcv(jpr_rnf)%laction = .TRUE. 
    374 ! This isn't right - really just want ln_rnf_emp changed 
    375 !                                                 IF( TRIM( sn_rcv_rnf%cldes ) == 'climato' )   THEN   ;   ln_rnf = .TRUE. 
    376 !                                                 ELSE                                                 ;   ln_rnf = .FALSE. 
    377 !                                                 ENDIF 
     402      srcv(jpr_rnf   )%clname = 'O_Runoff' 
     403      IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN 
     404         srcv(jpr_rnf)%laction = .TRUE. 
     405         l_rnfcpl              = .TRUE.                      ! -> no need to read runoffs in sbcrnf 
     406         ln_rnf                = nn_components /= jp_iam_sas ! -> force to go through sbcrnf if not sas 
     407         IF(lwp) WRITE(numout,*) 
     408         IF(lwp) WRITE(numout,*) '   runoffs received from oasis -> force ln_rnf = ', ln_rnf 
     409      ENDIF 
     410      ! 
    378411      srcv(jpr_cal   )%clname = 'OCalving'   ;   IF( TRIM( sn_rcv_cal%cldes ) == 'coupled' )   srcv(jpr_cal)%laction = .TRUE. 
    379412 
     
    385418      srcv(jpr_qnsmix)%clname = 'O_QnsMix' 
    386419      SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) 
     420      CASE( 'none'          )       ! nothing to do 
    387421      CASE( 'oce only'      )   ;   srcv(               jpr_qnsoce   )%laction = .TRUE. 
    388422      CASE( 'conservative'  )   ;   srcv( (/jpr_qnsice, jpr_qnsmix/) )%laction = .TRUE. 
     
    400434      srcv(jpr_qsrmix)%clname = 'O_QsrMix' 
    401435      SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) 
     436      CASE( 'none'          )       ! nothing to do 
    402437      CASE( 'oce only'      )   ;   srcv(               jpr_qsroce   )%laction = .TRUE. 
    403438      CASE( 'conservative'  )   ;   srcv( (/jpr_qsrice, jpr_qsrmix/) )%laction = .TRUE. 
     
    415450      ! 
    416451      ! non solar sensitivity mandatory for LIM ice model 
    417       IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4) & 
     452      IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4 .AND. nn_components /= jp_iam_sas ) & 
    418453         CALL ctl_stop( 'sbc_cpl_init: sn_rcv_dqnsdt%cldes must be coupled in namsbc_cpl namelist' ) 
    419454      ! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique 
     
    448483         srcv(jpr_topm:jpr_botm)%laction = .TRUE. 
    449484      ENDIF 
    450  
    451       ! Allocate all parts of frcv used for received fields 
     485      !                                                      ! ------------------------------- ! 
     486      !                                                      !   OPA-SAS coupling - rcv by opa !    
     487      !                                                      ! ------------------------------- ! 
     488      srcv(jpr_sflx)%clname = 'O_SFLX' 
     489      srcv(jpr_fice)%clname = 'RIceFrc' 
     490      ! 
     491      IF( nn_components == jp_iam_opa ) THEN    ! OPA coupled to SAS via OASIS: force received field by OPA (sent by SAS) 
     492         srcv(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling 
     493         srcv(:)%clgrid  = 'T'       ! force default definition in case of opa <-> sas coupling 
     494         srcv(:)%nsgn    = 1.        ! force default definition in case of opa <-> sas coupling 
     495         srcv( (/jpr_qsroce, jpr_qnsoce, jpr_oemp, jpr_sflx, jpr_fice, jpr_otx1, jpr_oty1, jpr_taum/) )%laction = .TRUE. 
     496         srcv(jpr_otx1)%clgrid = 'U'        ! oce components given at U-point 
     497         srcv(jpr_oty1)%clgrid = 'V'        !           and           V-point 
     498         ! Vectors: change of sign at north fold ONLY if on the local grid 
     499         srcv( (/jpr_otx1,jpr_oty1/) )%nsgn = -1. 
     500         sn_rcv_tau%clvgrd = 'U,V' 
     501         sn_rcv_tau%clvor = 'local grid' 
     502         sn_rcv_tau%clvref = 'spherical' 
     503         sn_rcv_emp%cldes = 'oce only' 
     504         ! 
     505         IF(lwp) THEN                        ! control print 
     506            WRITE(numout,*) 
     507            WRITE(numout,*)'               Special conditions for SAS-OPA coupling  ' 
     508            WRITE(numout,*)'               OPA component  ' 
     509            WRITE(numout,*) 
     510            WRITE(numout,*)'  received fields from SAS component ' 
     511            WRITE(numout,*)'                  ice cover ' 
     512            WRITE(numout,*)'                  oce only EMP  ' 
     513            WRITE(numout,*)'                  salt flux  ' 
     514            WRITE(numout,*)'                  mixed oce-ice solar flux  ' 
     515            WRITE(numout,*)'                  mixed oce-ice non solar flux  ' 
     516            WRITE(numout,*)'                  wind stress U,V on local grid and sperical coordinates ' 
     517            WRITE(numout,*)'                  wind stress module' 
     518            WRITE(numout,*) 
     519         ENDIF 
     520      ENDIF 
     521      !                                                      ! -------------------------------- ! 
     522      !                                                      !   OPA-SAS coupling - rcv by sas  !    
     523      !                                                      ! -------------------------------- ! 
     524      srcv(jpr_toce  )%clname = 'I_SSTSST' 
     525      srcv(jpr_soce  )%clname = 'I_SSSal' 
     526      srcv(jpr_ocx1  )%clname = 'I_OCurx1' 
     527      srcv(jpr_ocy1  )%clname = 'I_OCury1' 
     528      srcv(jpr_ssh   )%clname = 'I_SSHght' 
     529      srcv(jpr_e3t1st)%clname = 'I_E3T1st'    
     530      srcv(jpr_fraqsr)%clname = 'I_FraQsr'    
     531      ! 
     532      IF( nn_components == jp_iam_sas ) THEN 
     533         IF( .NOT. ln_cpl ) srcv(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling 
     534         IF( .NOT. ln_cpl ) srcv(:)%clgrid  = 'T'       ! force default definition in case of opa <-> sas coupling 
     535         IF( .NOT. ln_cpl ) srcv(:)%nsgn    = 1.        ! force default definition in case of opa <-> sas coupling 
     536         srcv( (/jpr_toce, jpr_soce, jpr_ssh, jpr_fraqsr, jpr_ocx1, jpr_ocy1/) )%laction = .TRUE. 
     537         srcv( jpr_e3t1st )%laction = lk_vvl 
     538         srcv(jpr_ocx1)%clgrid = 'U'        ! oce components given at U-point 
     539         srcv(jpr_ocy1)%clgrid = 'V'        !           and           V-point 
     540         ! Vectors: change of sign at north fold ONLY if on the local grid 
     541         srcv(jpr_ocx1:jpr_ocy1)%nsgn = -1. 
     542         ! Change first letter to couple with atmosphere if already coupled OPA 
     543         ! this is nedeed as each variable name used in the namcouple must be unique: 
     544         ! for example O_Runoff received by OPA from SAS and therefore O_Runoff received by SAS from the Atmosphere 
     545         DO jn = 1, jprcv 
     546            IF ( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname)) 
     547         END DO 
     548         ! 
     549         IF(lwp) THEN                        ! control print 
     550            WRITE(numout,*) 
     551            WRITE(numout,*)'               Special conditions for SAS-OPA coupling  ' 
     552            WRITE(numout,*)'               SAS component  ' 
     553            WRITE(numout,*) 
     554            IF( .NOT. ln_cpl ) THEN 
     555               WRITE(numout,*)'  received fields from OPA component ' 
     556            ELSE 
     557               WRITE(numout,*)'  Additional received fields from OPA component : ' 
     558            ENDIF 
     559            WRITE(numout,*)'               sea surface temperature (Celcius) ' 
     560            WRITE(numout,*)'               sea surface salinity '  
     561            WRITE(numout,*)'               surface currents '  
     562            WRITE(numout,*)'               sea surface height '  
     563            WRITE(numout,*)'               thickness of first ocean T level '         
     564            WRITE(numout,*)'               fraction of solar net radiation absorbed in the first ocean level' 
     565            WRITE(numout,*) 
     566         ENDIF 
     567      ENDIF 
     568       
     569      ! =================================================== ! 
     570      ! Allocate all parts of frcv used for received fields ! 
     571      ! =================================================== ! 
    452572      DO jn = 1, jprcv 
    453573         IF ( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) ) 
     
    455575      ! Allocate taum part of frcv which is used even when not received as coupling field 
    456576      IF ( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) ) 
     577      ! Allocate w10m part of frcv which is used even when not received as coupling field 
     578      IF ( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(jpi,jpj,srcv(jpr_w10m)%nct) ) 
     579      ! Allocate jpr_otx1 part of frcv which is used even when not received as coupling field 
     580      IF ( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(jpi,jpj,srcv(jpr_otx1)%nct) ) 
     581      IF ( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(jpi,jpj,srcv(jpr_oty1)%nct) ) 
    457582      ! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE. 
    458583      IF( k_ice /= 0 ) THEN 
     
    478603      ssnd(jps_tmix)%clname = 'O_TepMix' 
    479604      SELECT CASE( TRIM( sn_snd_temp%cldes ) ) 
    480       CASE( 'none'         )       ! nothing to do 
    481       CASE( 'oce only'             )   ;   ssnd(   jps_toce            )%laction = .TRUE. 
    482       CASE( 'weighted oce and ice' ) 
     605      CASE( 'none'                                 )       ! nothing to do 
     606      CASE( 'oce only'                             )   ;   ssnd( jps_toce )%laction = .TRUE. 
     607      CASE( 'oce and ice' , 'weighted oce and ice' ) 
    483608         ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE. 
    484609         IF ( TRIM( sn_snd_temp%clcat ) == 'yes' )  ssnd(jps_tice)%nct = jpl 
    485       CASE( 'mixed oce-ice'        )   ;   ssnd(   jps_tmix            )%laction = .TRUE. 
     610      CASE( 'mixed oce-ice'                        )   ;   ssnd( jps_tmix )%laction = .TRUE. 
    486611      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_temp%cldes' ) 
    487612      END SELECT 
    488       
     613            
    489614      !                                                      ! ------------------------- ! 
    490615      !                                                      !          Albedo           ! 
     
    493618      ssnd(jps_albmix)%clname = 'O_AlbMix' 
    494619      SELECT CASE( TRIM( sn_snd_alb%cldes ) ) 
    495       CASE( 'none'               ! nothing to do 
    496       CASE( 'weighted ice'  )   ;  ssnd(jps_albice)%laction = .TRUE. 
    497       CASE( 'mixed oce-ice' )   ;  ssnd(jps_albmix)%laction = .TRUE. 
     620      CASE( 'none'                 )     ! nothing to do 
     621      CASE( 'ice' , 'weighted ice' )   ; ssnd(jps_albice)%laction = .TRUE. 
     622      CASE( 'mixed oce-ice'        )   ; ssnd(jps_albmix)%laction = .TRUE. 
    498623      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_alb%cldes' ) 
    499624      END SELECT 
     
    519644         IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_fice)%nct = jpl 
    520645      ENDIF 
    521  
     646       
    522647      SELECT CASE ( TRIM( sn_snd_thick%cldes ) ) 
    523648      CASE( 'none'         )       ! nothing to do 
     
    526651         IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN 
    527652            ssnd(jps_hice:jps_hsnw)%nct = jpl 
    528          ELSE 
    529             IF ( jpl > 1 ) THEN 
    530 CALL ctl_stop( 'sbc_cpl_init: use weighted ice and snow option for sn_snd_thick%cldes if not exchanging category fields' ) 
    531             ENDIF 
    532653         ENDIF 
    533654      CASE ( 'weighted ice and snow' )  
     
    568689      !                                                      ! ------------------------- ! 
    569690      ssnd(jps_co2)%clname = 'O_CO2FLX' ;  IF( TRIM(sn_snd_co2%cldes) == 'coupled' )    ssnd(jps_co2 )%laction = .TRUE. 
     691 
     692      !                                                      ! ------------------------------- ! 
     693      !                                                      !   OPA-SAS coupling - snd by opa !    
     694      !                                                      ! ------------------------------- ! 
     695      ssnd(jps_ssh   )%clname = 'O_SSHght'  
     696      ssnd(jps_soce  )%clname = 'O_SSSal'  
     697      ssnd(jps_e3t1st)%clname = 'O_E3T1st'    
     698      ssnd(jps_fraqsr)%clname = 'O_FraQsr' 
     699      ! 
     700      IF( nn_components == jp_iam_opa ) THEN 
     701         ssnd(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling 
     702         ssnd( (/jps_toce, jps_soce, jps_ssh, jps_fraqsr, jps_ocx1, jps_ocy1/) )%laction = .TRUE. 
     703         ssnd( jps_e3t1st )%laction = lk_vvl 
     704         ! vector definition: not used but cleaner... 
     705         ssnd(jps_ocx1)%clgrid  = 'U'        ! oce components given at U-point 
     706         ssnd(jps_ocy1)%clgrid  = 'V'        !           and           V-point 
     707         sn_snd_crt%clvgrd = 'U,V' 
     708         sn_snd_crt%clvor = 'local grid' 
     709         sn_snd_crt%clvref = 'spherical' 
     710         ! 
     711         IF(lwp) THEN                        ! control print 
     712            WRITE(numout,*) 
     713            WRITE(numout,*)'  sent fields to SAS component ' 
     714            WRITE(numout,*)'               sea surface temperature (T before, Celcius) ' 
     715            WRITE(numout,*)'               sea surface salinity '  
     716            WRITE(numout,*)'               surface currents U,V on local grid and spherical coordinates'  
     717            WRITE(numout,*)'               sea surface height '  
     718            WRITE(numout,*)'               thickness of first ocean T level '         
     719            WRITE(numout,*)'               fraction of solar net radiation absorbed in the first ocean level' 
     720            WRITE(numout,*) 
     721         ENDIF 
     722      ENDIF 
     723      !                                                      ! ------------------------------- ! 
     724      !                                                      !   OPA-SAS coupling - snd by sas !    
     725      !                                                      ! ------------------------------- ! 
     726      ssnd(jps_sflx  )%clname = 'I_SFLX'      
     727      ssnd(jps_fice2 )%clname = 'IIceFrc' 
     728      ssnd(jps_qsroce)%clname = 'I_QsrOce'    
     729      ssnd(jps_qnsoce)%clname = 'I_QnsOce'    
     730      ssnd(jps_oemp  )%clname = 'IOEvaMPr'  
     731      ssnd(jps_otx1  )%clname = 'I_OTaux1'    
     732      ssnd(jps_oty1  )%clname = 'I_OTauy1'    
     733      ssnd(jps_rnf   )%clname = 'I_Runoff'    
     734      ssnd(jps_taum  )%clname = 'I_TauMod'    
     735      ! 
     736      IF( nn_components == jp_iam_sas ) THEN 
     737         IF( .NOT. ln_cpl ) ssnd(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling 
     738         ssnd( (/jps_qsroce, jps_qnsoce, jps_oemp, jps_fice2, jps_sflx, jps_otx1, jps_oty1, jps_taum/) )%laction = .TRUE. 
     739         ! 
     740         ! Change first letter to couple with atmosphere if already coupled with sea_ice 
     741         ! this is nedeed as each variable name used in the namcouple must be unique: 
     742         ! for example O_SSTSST sent by OPA to SAS and therefore S_SSTSST sent by SAS to the Atmosphere 
     743         DO jn = 1, jpsnd 
     744            IF ( ssnd(jn)%clname(1:1) == "O" ) ssnd(jn)%clname = "S"//ssnd(jn)%clname(2:LEN(ssnd(jn)%clname)) 
     745         END DO 
     746         ! 
     747         IF(lwp) THEN                        ! control print 
     748            WRITE(numout,*) 
     749            IF( .NOT. ln_cpl ) THEN 
     750               WRITE(numout,*)'  sent fields to OPA component ' 
     751            ELSE 
     752               WRITE(numout,*)'  Additional sent fields to OPA component : ' 
     753            ENDIF 
     754            WRITE(numout,*)'                  ice cover ' 
     755            WRITE(numout,*)'                  oce only EMP  ' 
     756            WRITE(numout,*)'                  salt flux  ' 
     757            WRITE(numout,*)'                  mixed oce-ice solar flux  ' 
     758            WRITE(numout,*)'                  mixed oce-ice non solar flux  ' 
     759            WRITE(numout,*)'                  wind stress U,V components' 
     760            WRITE(numout,*)'                  wind stress module' 
     761         ENDIF 
     762      ENDIF 
     763 
    570764      ! 
    571765      ! ================================ ! 
     
    573767      ! ================================ ! 
    574768 
    575       CALL cpl_define(jprcv, jpsnd,nn_cplmodel)             
     769      CALL cpl_define(jprcv, jpsnd, nn_cplmodel) 
     770       
    576771      IF (ln_usecplmask) THEN  
    577772         xcplmask(:,:,:) = 0. 
     
    583778         xcplmask(:,:,:) = 1. 
    584779      ENDIF 
    585       ! 
    586       IF( ln_dm2dc .AND. ( cpl_freq( jpr_qsroce ) + cpl_freq( jpr_qsrmix ) /= 86400 ) )   & 
     780      xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 ) 
     781      ! 
     782      ncpl_qsr_freq = cpl_freq( 'O_QsrOce' ) + cpl_freq( 'O_QsrMix' ) + cpl_freq( 'I_QsrOce' ) + cpl_freq( 'I_QsrMix' ) 
     783      IF( ln_dm2dc .AND. ln_cpl .AND. ncpl_qsr_freq /= 86400 )   & 
    587784         &   CALL ctl_stop( 'sbc_cpl_init: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' ) 
     785      ncpl_qsr_freq = 86400 / ncpl_qsr_freq 
    588786 
    589787      CALL wrk_dealloc( jpi,jpj, zacs, zaos ) 
     
    639837      !!                        emp          upward mass flux [evap. - precip. (- runoffs) (- calving)] (ocean only case) 
    640838      !!---------------------------------------------------------------------- 
    641       INTEGER, INTENT(in) ::   kt       ! ocean model time step index 
    642       INTEGER, INTENT(in) ::   k_fsbc   ! frequency of sbc (-> ice model) computation  
    643       INTEGER, INTENT(in) ::   k_ice    ! ice management in the sbc (=0/1/2/3) 
    644       !! 
    645       LOGICAL ::    llnewtx, llnewtau      ! update wind stress components and module?? 
     839      INTEGER, INTENT(in)           ::   kt          ! ocean model time step index 
     840      INTEGER, INTENT(in)           ::   k_fsbc      ! frequency of sbc (-> ice model) computation  
     841      INTEGER, INTENT(in)           ::   k_ice       ! ice management in the sbc (=0/1/2/3) 
     842 
     843      !! 
     844      LOGICAL  ::   llnewtx, llnewtau      ! update wind stress components and module?? 
    646845      INTEGER  ::   ji, jj, jn             ! dummy loop indices 
    647846      INTEGER  ::   isec                   ! number of seconds since nit000 (assuming rdttra did not change since nit000) 
     
    651850      REAL(wp) ::   zcdrag = 1.5e-3        ! drag coefficient 
    652851      REAL(wp) ::   zzx, zzy               ! temporary variables 
    653       REAL(wp), POINTER, DIMENSION(:,:) ::   ztx, zty  
     852      REAL(wp), POINTER, DIMENSION(:,:) ::   ztx, zty, zmsk, zemp, zqns, zqsr 
    654853      !!---------------------------------------------------------------------- 
    655854      ! 
    656855      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_rcv') 
    657856      ! 
    658       CALL wrk_alloc( jpi,jpj, ztx, zty ) 
    659       !                                                 ! Receive all the atmos. fields (including ice information) 
    660       isec = ( kt - nit000 ) * NINT( rdttra(1) )             ! date of exchanges 
    661       DO jn = 1, jprcv                                       ! received fields sent by the atmosphere 
    662          IF( srcv(jn)%laction )   CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask, nrcvinfo(jn) ) 
     857      CALL wrk_alloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr ) 
     858      ! 
     859      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
     860      ! 
     861      !                                                      ! ======================================================= ! 
     862      !                                                      ! Receive all the atmos. fields (including ice information) 
     863      !                                                      ! ======================================================= ! 
     864      isec = ( kt - nit000 ) * NINT( rdttra(1) )                ! date of exchanges 
     865      DO jn = 1, jprcv                                          ! received fields sent by the atmosphere 
     866         IF( srcv(jn)%laction )   CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask(:,:,1:nn_cplmodel), nrcvinfo(jn) ) 
    663867      END DO 
    664868 
     
    720924         ! 
    721925      ENDIF 
    722        
    723926      !                                                      ! ========================= ! 
    724927      !                                                      !    wind stress module     !   (taum) 
     
    749952         ENDIF 
    750953      ENDIF 
    751        
     954      ! 
    752955      !                                                      ! ========================= ! 
    753956      !                                                      !      10 m wind speed      !   (wndm) 
     
    762965!CDIR NOVERRCHK 
    763966               DO ji = 1, jpi  
    764                   wndm(ji,jj) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) 
     967                  frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) 
    765968               END DO 
    766969            END DO 
    767970         ENDIF 
    768       ELSE 
    769          IF ( nrcvinfo(jpr_w10m) == OASIS_Rcv ) wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1) 
    770971      ENDIF 
    771972 
     
    774975      IF( MOD( kt-1, k_fsbc ) == 0 ) THEN 
    775976         ! 
    776          utau(:,:) = frcv(jpr_otx1)%z3(:,:,1) 
    777          vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1) 
    778          taum(:,:) = frcv(jpr_taum)%z3(:,:,1) 
     977         IF( ln_mixcpl ) THEN 
     978            utau(:,:) = utau(:,:) * xcplmask(:,:,0) + frcv(jpr_otx1)%z3(:,:,1) * zmsk(:,:) 
     979            vtau(:,:) = vtau(:,:) * xcplmask(:,:,0) + frcv(jpr_oty1)%z3(:,:,1) * zmsk(:,:) 
     980            taum(:,:) = taum(:,:) * xcplmask(:,:,0) + frcv(jpr_taum)%z3(:,:,1) * zmsk(:,:) 
     981            wndm(:,:) = wndm(:,:) * xcplmask(:,:,0) + frcv(jpr_w10m)%z3(:,:,1) * zmsk(:,:) 
     982         ELSE 
     983            utau(:,:) = frcv(jpr_otx1)%z3(:,:,1) 
     984            vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1) 
     985            taum(:,:) = frcv(jpr_taum)%z3(:,:,1) 
     986            wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1) 
     987         ENDIF 
    779988         CALL iom_put( "taum_oce", taum )   ! output wind stress module 
    780989         !   
     
    782991 
    783992#if defined key_cpl_carbon_cycle 
    784       !                                                              ! atmosph. CO2 (ppm) 
     993      !                                                      ! ================== ! 
     994      !                                                      ! atmosph. CO2 (ppm) ! 
     995      !                                                      ! ================== ! 
    785996      IF( srcv(jpr_co2)%laction )   atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1) 
    786997#endif 
    787998 
     999      !  Fields received by SAS when OASIS coupling 
     1000      !  (arrays no more filled at sbcssm stage) 
     1001      !                                                      ! ================== ! 
     1002      !                                                      !        SSS         ! 
     1003      !                                                      ! ================== ! 
     1004      IF( srcv(jpr_soce)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
     1005         sss_m(:,:) = frcv(jpr_soce)%z3(:,:,1) 
     1006         CALL iom_put( 'sss_m', sss_m ) 
     1007      ENDIF 
     1008      !                                                
     1009      !                                                      ! ================== ! 
     1010      !                                                      !        SST         ! 
     1011      !                                                      ! ================== ! 
     1012      IF( srcv(jpr_toce)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
     1013         sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1) 
     1014         IF( srcv(jpr_soce)%laction .AND. ln_useCT ) THEN    ! make sure that sst_m is the potential temperature 
     1015            sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) ) 
     1016         ENDIF 
     1017      ENDIF 
     1018      !                                                      ! ================== ! 
     1019      !                                                      !        SSH         ! 
     1020      !                                                      ! ================== ! 
     1021      IF( srcv(jpr_ssh )%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
     1022         ssh_m(:,:) = frcv(jpr_ssh )%z3(:,:,1) 
     1023         CALL iom_put( 'ssh_m', ssh_m ) 
     1024      ENDIF 
     1025      !                                                      ! ================== ! 
     1026      !                                                      !  surface currents  ! 
     1027      !                                                      ! ================== ! 
     1028      IF( srcv(jpr_ocx1)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
     1029         ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 
     1030         ub (:,:,1) = ssu_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1031         CALL iom_put( 'ssu_m', ssu_m ) 
     1032      ENDIF 
     1033      IF( srcv(jpr_ocy1)%laction ) THEN 
     1034         ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 
     1035         vb (:,:,1) = ssv_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1036         CALL iom_put( 'ssv_m', ssv_m ) 
     1037      ENDIF 
     1038      !                                                      ! ======================== ! 
     1039      !                                                      !  first T level thickness ! 
     1040      !                                                      ! ======================== ! 
     1041      IF( srcv(jpr_e3t1st )%laction ) THEN                   ! received by sas in case of opa <-> sas coupling 
     1042         e3t_m(:,:) = frcv(jpr_e3t1st )%z3(:,:,1) 
     1043         CALL iom_put( 'e3t_m', e3t_m(:,:) ) 
     1044      ENDIF 
     1045      !                                                      ! ================================ ! 
     1046      !                                                      !  fraction of solar net radiation ! 
     1047      !                                                      ! ================================ ! 
     1048      IF( srcv(jpr_fraqsr)%laction ) THEN                    ! received by sas in case of opa <-> sas coupling 
     1049         frq_m(:,:) = frcv(jpr_fraqsr)%z3(:,:,1) 
     1050         CALL iom_put( 'frq_m', frq_m ) 
     1051      ENDIF 
     1052       
    7881053      !                                                      ! ========================= ! 
    789       IF( k_ice <= 1 ) THEN                                  !  heat & freshwater fluxes ! (Ocean only case) 
     1054      IF( k_ice <= 1 .AND. MOD( kt-1, k_fsbc ) == 0 ) THEN   !  heat & freshwater fluxes ! (Ocean only case) 
    7901055         !                                                   ! ========================= ! 
    7911056         ! 
    7921057         !                                                       ! total freshwater fluxes over the ocean (emp) 
    793          SELECT CASE( TRIM( sn_rcv_emp%cldes ) )                                    ! evaporation - precipitation 
    794          CASE( 'conservative' ) 
    795             emp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) ) 
    796          CASE( 'oce only', 'oce and ice' ) 
    797             emp(:,:) = frcv(jpr_oemp)%z3(:,:,1) 
    798          CASE default 
    799             CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' ) 
    800          END SELECT 
     1058         IF( srcv(jpr_oemp)%laction .OR. srcv(jpr_rain)%laction ) THEN 
     1059            SELECT CASE( TRIM( sn_rcv_emp%cldes ) )                                    ! evaporation - precipitation 
     1060            CASE( 'conservative' ) 
     1061               zemp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) ) 
     1062            CASE( 'oce only', 'oce and ice' ) 
     1063               zemp(:,:) = frcv(jpr_oemp)%z3(:,:,1) 
     1064            CASE default 
     1065               CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' ) 
     1066            END SELECT 
     1067         ELSE 
     1068            zemp(:,:) = 0._wp 
     1069         ENDIF 
    8011070         ! 
    8021071         !                                                        ! runoffs and calving (added in emp) 
    803          IF( srcv(jpr_rnf)%laction )   emp(:,:) = emp(:,:) - frcv(jpr_rnf)%z3(:,:,1) 
    804          IF( srcv(jpr_cal)%laction )   emp(:,:) = emp(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    805          ! 
    806 !!gm :  this seems to be internal cooking, not sure to need that in a generic interface  
    807 !!gm                                       at least should be optional... 
    808 !!         IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN     ! add to the total freshwater budget 
    809 !!            ! remove negative runoff 
    810 !!            zcumulpos = SUM( MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )  
    811 !!            zcumulneg = SUM( MIN( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 
    812 !!            IF( lk_mpp )   CALL mpp_sum( zcumulpos )   ! sum over the global domain 
    813 !!            IF( lk_mpp )   CALL mpp_sum( zcumulneg )  
    814 !!            IF( zcumulpos /= 0. ) THEN                 ! distribute negative runoff on positive runoff grid points 
    815 !!               zcumulneg = 1.e0 + zcumulneg / zcumulpos 
    816 !!               frcv(jpr_rnf)%z3(:,:,1) = MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * zcumulneg 
    817 !!            ENDIF      
    818 !!            ! add runoff to e-p  
    819 !!            emp(:,:) = emp(:,:) - frcv(jpr_rnf)%z3(:,:,1) 
    820 !!         ENDIF 
    821 !!gm  end of internal cooking 
     1072         IF( srcv(jpr_rnf)%laction )     rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1073         IF( srcv(jpr_cal)%laction )     zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1074          
     1075         IF( ln_mixcpl ) THEN   ;   emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:) 
     1076         ELSE                   ;   emp(:,:) =                              zemp(:,:) 
     1077         ENDIF 
    8221078         ! 
    8231079         !                                                       ! non solar heat flux over the ocean (qns) 
    824          IF( srcv(jpr_qnsoce)%laction )   qns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
    825          IF( srcv(jpr_qnsmix)%laction )   qns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1080         IF(      srcv(jpr_qnsoce)%laction ) THEN   ;   zqns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1081         ELSE IF( srcv(jpr_qnsmix)%laction ) THEN   ;   zqns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1082         ELSE                                       ;   zqns(:,:) = 0._wp 
     1083         END IF 
    8261084         ! update qns over the free ocean with: 
    827          qns(:,:) =  qns(:,:) - emp(:,:) * sst_m(:,:) * rcp            ! remove heat content due to mass flux (assumed to be at SST) 
    828          IF( srcv(jpr_snow  )%laction )   THEN 
    829               qns(:,:) = qns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus    ! energy for melting solid precipitation over the free ocean 
     1085         IF( nn_components /= jp_iam_opa ) THEN 
     1086            zqns(:,:) =  zqns(:,:) - zemp(:,:) * sst_m(:,:) * rcp         ! remove heat content due to mass flux (assumed to be at SST) 
     1087            IF( srcv(jpr_snow  )%laction ) THEN 
     1088               zqns(:,:) = zqns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus    ! energy for melting solid precipitation over the free ocean 
     1089            ENDIF 
     1090         ENDIF 
     1091         IF( ln_mixcpl ) THEN   ;   qns(:,:) = qns(:,:) * xcplmask(:,:,0) + zqns(:,:) * zmsk(:,:) 
     1092         ELSE                   ;   qns(:,:) =                              zqns(:,:) 
    8301093         ENDIF 
    8311094 
    8321095         !                                                       ! solar flux over the ocean          (qsr) 
    833          IF( srcv(jpr_qsroce)%laction )   qsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1) 
    834          IF( srcv(jpr_qsrmix)%laction )   qsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1) 
    835          IF( ln_dm2dc )   qsr(:,:) = sbc_dcy( qsr )                           ! modify qsr to include the diurnal cycle 
     1096         IF     ( srcv(jpr_qsroce)%laction ) THEN   ;   zqsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1) 
     1097         ELSE IF( srcv(jpr_qsrmix)%laction ) then   ;   zqsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1) 
     1098         ELSE                                       ;   zqsr(:,:) = 0._wp 
     1099         ENDIF 
     1100         IF( ln_dm2dc .AND. ln_cpl )   zqsr(:,:) = sbc_dcy( zqsr )   ! modify qsr to include the diurnal cycle 
     1101         IF( ln_mixcpl ) THEN   ;   qsr(:,:) = qsr(:,:) * xcplmask(:,:,0) + zqsr(:,:) * zmsk(:,:) 
     1102         ELSE                   ;   qsr(:,:) =                              zqsr(:,:) 
     1103         ENDIF 
    8361104         ! 
    837    
    838       ENDIF 
    839       ! 
    840       CALL wrk_dealloc( jpi,jpj, ztx, zty ) 
     1105         ! salt flux over the ocean (received by opa in case of opa <-> sas coupling) 
     1106         IF( srcv(jpr_sflx )%laction )   sfx(:,:) = frcv(jpr_sflx  )%z3(:,:,1) 
     1107         ! Ice cover  (received by opa in case of opa <-> sas coupling) 
     1108         IF( srcv(jpr_fice )%laction )   fr_i(:,:) = frcv(jpr_fice )%z3(:,:,1) 
     1109         ! 
     1110 
     1111      ENDIF 
     1112      ! 
     1113      CALL wrk_dealloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr ) 
    8411114      ! 
    8421115      IF( nn_timing == 1 )  CALL timing_stop('sbc_cpl_rcv') 
     
    9351208            ! 
    9361209         ENDIF 
    937  
    9381210         !                                                      ! ======================= ! 
    9391211         !                                                      !     put on ice grid     ! 
     
    10571329    
    10581330 
    1059    SUBROUTINE sbc_cpl_ice_flx( p_frld  , palbi   , psst    , pist    ) 
     1331   SUBROUTINE sbc_cpl_ice_flx( p_frld, palbi, psst, pist ) 
    10601332      !!---------------------------------------------------------------------- 
    10611333      !!             ***  ROUTINE sbc_cpl_ice_flx  *** 
     
    10991371      REAL(wp), INTENT(in   ), DIMENSION(:,:)   ::   p_frld     ! lead fraction                [0 to 1] 
    11001372      ! optional arguments, used only in 'mixed oce-ice' case 
    1101       REAL(wp), INTENT(in   ), DIMENSION(:,:,:), OPTIONAL ::   palbi   ! all skies ice albedo  
    1102       REAL(wp), INTENT(in   ), DIMENSION(:,:  ), OPTIONAL ::   psst    ! sea surface temperature     [Celsius] 
    1103       REAL(wp), INTENT(in   ), DIMENSION(:,:,:), OPTIONAL ::   pist    ! ice surface temperature     [Kelvin] 
    1104       ! 
    1105       INTEGER ::   jl   ! dummy loop index 
    1106       REAL(wp), POINTER, DIMENSION(:,:) ::   zcptn, ztmp, zicefr 
     1373      REAL(wp), INTENT(in   ), DIMENSION(:,:,:), OPTIONAL ::   palbi      ! all skies ice albedo  
     1374      REAL(wp), INTENT(in   ), DIMENSION(:,:  ), OPTIONAL ::   psst       ! sea surface temperature     [Celsius] 
     1375      REAL(wp), INTENT(in   ), DIMENSION(:,:,:), OPTIONAL ::   pist       ! ice surface temperature     [Kelvin] 
     1376      ! 
     1377      INTEGER ::   jl         ! dummy loop index 
     1378      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk 
     1379      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot 
     1380      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice 
     1381      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM3 
    11071382      !!---------------------------------------------------------------------- 
    11081383      ! 
    11091384      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_ice_flx') 
    11101385      ! 
    1111       CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr ) 
    1112  
     1386      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
     1387      CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
     1388 
     1389      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    11131390      zicefr(:,:) = 1.- p_frld(:,:) 
    11141391      zcptn(:,:) = rcp * sst_m(:,:) 
     
    11181395      !                                                      ! ========================= ! 
    11191396      ! 
    1120       !                                                           ! total Precipitations - total Evaporation (emp_tot) 
    1121       !                                                           ! solid precipitation  - sublimation       (emp_ice) 
    1122       !                                                           ! solid Precipitation                      (sprecip) 
     1397      !                                                           ! total Precipitation - total Evaporation (emp_tot) 
     1398      !                                                           ! solid precipitation - sublimation       (emp_ice) 
     1399      !                                                           ! solid Precipitation                     (sprecip) 
     1400      !                                                           ! liquid + solid Precipitation            (tprecip) 
    11231401      SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 
    11241402      CASE( 'conservative'  )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
    1125          sprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)                 ! May need to ensure positive here 
    1126          tprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + sprecip (:,:) ! May need to ensure positive here 
    1127          emp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - tprecip(:,:) 
    1128          emp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 
     1403         zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
     1404         ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here 
     1405         zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
     1406         zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 
    11291407            CALL iom_put( 'rain'         , frcv(jpr_rain)%z3(:,:,1)              )   ! liquid precipitation  
    11301408         IF( iom_use('hflx_rain_cea') )   & 
     
    11371415            CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) )   ! heat flux from from evap (cell average) 
    11381416      CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    1139          emp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    1140          emp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 
    1141          sprecip(:,:) = - frcv(jpr_semp)%z3(:,:,1) + frcv(jpr_ievp)%z3(:,:,1) 
     1417         zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
     1418         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 
     1419         zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 
     1420         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 
    11421421      END SELECT 
     1422 
     1423      IF( iom_use('subl_ai_cea') )   & 
     1424         CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )   ! Sublimation over sea-ice         (cell average) 
     1425      !    
     1426      !                                                           ! runoffs and calving (put in emp_tot) 
     1427      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1428      IF( srcv(jpr_cal)%laction ) THEN  
     1429         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1430         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
     1431      ENDIF 
     1432 
     1433      IF( ln_mixcpl ) THEN 
     1434         emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 
     1435         emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 
     1436         sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 
     1437         tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 
     1438      ELSE 
     1439         emp_tot(:,:) =                                  zemp_tot(:,:) 
     1440         emp_ice(:,:) =                                  zemp_ice(:,:) 
     1441         sprecip(:,:) =                                  zsprecip(:,:) 
     1442         tprecip(:,:) =                                  ztprecip(:,:) 
     1443      ENDIF 
    11431444 
    11441445         CALL iom_put( 'snowpre'    , sprecip                                )   ! Snow 
     
    11471448      IF( iom_use('snow_ai_cea') )   & 
    11481449         CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:)             )   ! Snow        over sea-ice         (cell average) 
    1149       IF( iom_use('subl_ai_cea') )   & 
    1150          CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )   ! Sublimation over sea-ice         (cell average) 
    1151       !    
    1152       !                                                           ! runoffs and calving (put in emp_tot) 
    1153       IF( srcv(jpr_rnf)%laction ) THEN  
    1154          emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_rnf)%z3(:,:,1) 
    1155             CALL iom_put( 'runoffs'      , frcv(jpr_rnf)%z3(:,:,1)              )   ! rivers 
    1156          IF( iom_use('hflx_rnf_cea') )   & 
    1157             CALL iom_put( 'hflx_rnf_cea' , frcv(jpr_rnf)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from rivers 
    1158       ENDIF 
    1159       IF( srcv(jpr_cal)%laction ) THEN  
    1160          emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    1161          CALL iom_put( 'calving', frcv(jpr_cal)%z3(:,:,1) ) 
    1162       ENDIF 
    1163       ! 
    1164 !!gm :  this seems to be internal cooking, not sure to need that in a generic interface  
    1165 !!gm                                       at least should be optional... 
    1166 !!       ! remove negative runoff                            ! sum over the global domain 
    1167 !!       zcumulpos = SUM( MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )  
    1168 !!       zcumulneg = SUM( MIN( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 
    1169 !!       IF( lk_mpp )   CALL mpp_sum( zcumulpos ) 
    1170 !!       IF( lk_mpp )   CALL mpp_sum( zcumulneg )  
    1171 !!       IF( zcumulpos /= 0. ) THEN                          ! distribute negative runoff on positive runoff grid points 
    1172 !!          zcumulneg = 1.e0 + zcumulneg / zcumulpos 
    1173 !!          frcv(jpr_rnf)%z3(:,:,1) = MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * zcumulneg 
    1174 !!       ENDIF      
    1175 !!       emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_rnf)%z3(:,:,1)   ! add runoff to e-p  
    1176 !! 
    1177 !!gm  end of internal cooking 
    11781450 
    11791451      !                                                      ! ========================= ! 
     
    11811453      !                                                      ! ========================= ! 
    11821454      CASE( 'oce only' )                                     ! the required field is directly provided 
    1183          qns_tot(:,:  ) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1455         zqns_tot(:,:  ) = frcv(jpr_qnsoce)%z3(:,:,1) 
    11841456      CASE( 'conservative' )                                      ! the required fields are directly provided 
    1185          qns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1457         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    11861458         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    1187             qns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 
     1459            zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 
    11881460         ELSE 
    11891461            ! Set all category values equal for the moment 
    11901462            DO jl=1,jpl 
    1191                qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
     1463               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
    11921464            ENDDO 
    11931465         ENDIF 
    11941466      CASE( 'oce and ice' )       ! the total flux is computed from ocean and ice fluxes 
    1195          qns_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
     1467         zqns_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
    11961468         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    11971469            DO jl=1,jpl 
    1198                qns_tot(:,:   ) = qns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl)    
    1199                qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl) 
     1470               zqns_tot(:,:   ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl)    
     1471               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl) 
    12001472            ENDDO 
    12011473         ELSE 
     1474            qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    12021475            DO jl=1,jpl 
    1203                qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    1204                qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
     1476               zqns_tot(:,:   ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     1477               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
    12051478            ENDDO 
    12061479         ENDIF 
    12071480      CASE( 'mixed oce-ice' )     ! the ice flux is cumputed from the total flux, the SST and ice informations 
    12081481! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 
    1209          qns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    1210          qns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
     1482         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1483         zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
    12111484            &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * p_frld(:,:)   & 
    12121485            &                                                   +          pist(:,:,1)   * zicefr(:,:) ) ) 
    12131486      END SELECT 
    1214       ztmp(:,:) = p_frld(:,:) * sprecip(:,:) * lfus 
    1215       qns_tot(:,:) = qns_tot(:,:)                         &            ! qns_tot update over free ocean with: 
    1216          &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
    1217          &          - (  emp_tot(:,:)                     &            ! remove the heat content of mass flux (assumed to be at SST) 
    1218          &             - emp_ice(:,:) * zicefr(:,:)  ) * zcptn(:,:)  
    1219       IF( iom_use('hflx_snow_cea') )   & 
    1220          CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) )   ! heat flux from snow (cell average) 
    12211487!!gm 
    1222 !!    currently it is taken into account in leads budget but not in the qns_tot, and thus not in  
     1488!!    currently it is taken into account in leads budget but not in the zqns_tot, and thus not in  
    12231489!!    the flux that enter the ocean.... 
    12241490!!    moreover 1 - it is not diagnose anywhere....  
     
    12291495      IF( srcv(jpr_cal)%laction ) THEN                            ! Iceberg melting  
    12301496         ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus               ! add the latent heat of iceberg melting  
    1231          qns_tot(:,:) = qns_tot(:,:) - ztmp(:,:) 
     1497         zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:) 
    12321498         IF( iom_use('hflx_cal_cea') )   & 
    12331499            CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from calving 
    12341500      ENDIF 
     1501 
     1502      ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus 
     1503      IF( iom_use('hflx_snow_cea') )    CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) )   ! heat flux from snow (cell average) 
     1504 
     1505#if defined key_lim3 
     1506      CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
     1507 
     1508      ! --- evaporation --- ! 
     1509      ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation 
     1510      ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice 
     1511      !                 but it is incoherent WITH the ice model   
     1512      DO jl=1,jpl 
     1513         evap_ice(:,:,jl) = 0._wp  ! should be: frcv(jpr_ievp)%z3(:,:,1) 
     1514      ENDDO 
     1515      zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 
     1516 
     1517      ! --- evaporation minus precipitation --- ! 
     1518      emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:) 
     1519 
     1520      ! --- non solar flux over ocean --- ! 
     1521      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
     1522      zqns_oce = 0._wp 
     1523      WHERE( p_frld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 
     1524 
     1525      ! --- heat flux associated with emp --- ! 
     1526      zsnw(:,:) = 0._wp 
     1527      CALL lim_thd_snwblow( p_frld, zsnw )  ! snow distribution over ice after wind blowing 
     1528      zqemp_oce(:,:) = -      zevap(:,:)                   * p_frld(:,:)      *   zcptn(:,:)   &      ! evap 
     1529         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &      ! liquid precip 
     1530         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 
     1531      qemp_ice(:,:)  = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
     1532         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
     1533 
     1534      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     1535      zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
     1536 
     1537      ! --- total non solar flux --- ! 
     1538      zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 
     1539 
     1540      ! --- in case both coupled/forced are active, we must mix values --- !  
     1541      IF( ln_mixcpl ) THEN 
     1542         qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:) 
     1543         qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 
     1544         DO jl=1,jpl 
     1545            qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:) 
     1546         ENDDO 
     1547         qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 
     1548         qemp_oce (:,:) =  qemp_oce(:,:) * xcplmask(:,:,0) +  zqemp_oce(:,:)* zmsk(:,:) 
     1549!!clem         evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0) 
     1550      ELSE 
     1551         qns_tot  (:,:  ) = zqns_tot  (:,:  ) 
     1552         qns_oce  (:,:  ) = zqns_oce  (:,:  ) 
     1553         qns_ice  (:,:,:) = zqns_ice  (:,:,:) 
     1554         qprec_ice(:,:)   = zqprec_ice(:,:) 
     1555         qemp_oce (:,:)   = zqemp_oce (:,:) 
     1556      ENDIF 
     1557 
     1558      CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
     1559#else 
     1560 
     1561      ! clem: this formulation is certainly wrong... but better than it was... 
     1562      zqns_tot(:,:) = zqns_tot(:,:)                       &            ! zqns_tot update over free ocean with: 
     1563         &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
     1564         &          - (  zemp_tot(:,:)                    &            ! remove the heat content of mass flux (assumed to be at SST) 
     1565         &             - zemp_ice(:,:) * zicefr(:,:)  ) * zcptn(:,:)  
     1566 
     1567     IF( ln_mixcpl ) THEN 
     1568         qns_tot(:,:) = qns(:,:) * p_frld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 )   ! total flux from blk 
     1569         qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) +  zqns_tot(:,:)* zmsk(:,:) 
     1570         DO jl=1,jpl 
     1571            qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:) 
     1572         ENDDO 
     1573      ELSE 
     1574         qns_tot(:,:  ) = zqns_tot(:,:  ) 
     1575         qns_ice(:,:,:) = zqns_ice(:,:,:) 
     1576      ENDIF 
     1577 
     1578#endif 
    12351579 
    12361580      !                                                      ! ========================= ! 
     
    12381582      !                                                      ! ========================= ! 
    12391583      CASE( 'oce only' ) 
    1240          qsr_tot(:,:  ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) ) 
     1584         zqsr_tot(:,:  ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) ) 
    12411585      CASE( 'conservative' ) 
    1242          qsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
     1586         zqsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
    12431587         IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 
    1244             qsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl) 
     1588            zqsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl) 
    12451589         ELSE 
    12461590            ! Set all category values equal for the moment 
    12471591            DO jl=1,jpl 
    1248                qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 
     1592               zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 
    12491593            ENDDO 
    12501594         ENDIF 
    1251          qsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
    1252          qsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1) 
     1595         zqsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
     1596         zqsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1) 
    12531597      CASE( 'oce and ice' ) 
    1254          qsr_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) 
     1598         zqsr_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) 
    12551599         IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 
    12561600            DO jl=1,jpl 
    1257                qsr_tot(:,:   ) = qsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl)    
    1258                qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl) 
     1601               zqsr_tot(:,:   ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl)    
     1602               zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl) 
    12591603            ENDDO 
    12601604         ELSE 
     1605            qsr_tot(:,:   ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
    12611606            DO jl=1,jpl 
    1262                qsr_tot(:,:   ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
    1263                qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 
     1607               zqsr_tot(:,:   ) = zqsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
     1608               zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 
    12641609            ENDDO 
    12651610         ENDIF 
    12661611      CASE( 'mixed oce-ice' ) 
    1267          qsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
     1612         zqsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
    12681613! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 
    12691614!       Create solar heat flux over ice using incoming solar heat flux and albedos 
    12701615!       ( see OASIS3 user guide, 5th edition, p39 ) 
    1271          qsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) )   & 
     1616         zqsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) )   & 
    12721617            &            / (  1.- ( albedo_oce_mix(:,:  ) * p_frld(:,:)       & 
    12731618            &                     + palbi         (:,:,1) * zicefr(:,:) ) ) 
    12741619      END SELECT 
    1275       IF( ln_dm2dc ) THEN   ! modify qsr to include the diurnal cycle 
    1276          qsr_tot(:,:  ) = sbc_dcy( qsr_tot(:,:  ) ) 
     1620      IF( ln_dm2dc .AND. ln_cpl ) THEN   ! modify qsr to include the diurnal cycle 
     1621         zqsr_tot(:,:  ) = sbc_dcy( zqsr_tot(:,:  ) ) 
    12771622         DO jl=1,jpl 
    1278             qsr_ice(:,:,jl) = sbc_dcy( qsr_ice(:,:,jl) ) 
     1623            zqsr_ice(:,:,jl) = sbc_dcy( zqsr_ice(:,:,jl) ) 
    12791624         ENDDO 
     1625      ENDIF 
     1626 
     1627#if defined key_lim3 
     1628      CALL wrk_alloc( jpi,jpj, zqsr_oce )  
     1629      ! --- solar flux over ocean --- ! 
     1630      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
     1631      zqsr_oce = 0._wp 
     1632      WHERE( p_frld /= 0._wp )  zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / p_frld(:,:) 
     1633 
     1634      IF( ln_mixcpl ) THEN   ;   qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) +  zqsr_oce(:,:)* zmsk(:,:) 
     1635      ELSE                   ;   qsr_oce(:,:) = zqsr_oce(:,:)   ;   ENDIF 
     1636 
     1637      CALL wrk_dealloc( jpi,jpj, zqsr_oce )  
     1638#endif 
     1639 
     1640      IF( ln_mixcpl ) THEN 
     1641         qsr_tot(:,:) = qsr(:,:) * p_frld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 )   ! total flux from blk 
     1642         qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) +  zqsr_tot(:,:)* zmsk(:,:) 
     1643         DO jl=1,jpl 
     1644            qsr_ice(:,:,jl) = qsr_ice(:,:,jl) * xcplmask(:,:,0) +  zqsr_ice(:,:,jl)* zmsk(:,:) 
     1645         ENDDO 
     1646      ELSE 
     1647         qsr_tot(:,:  ) = zqsr_tot(:,:  ) 
     1648         qsr_ice(:,:,:) = zqsr_ice(:,:,:) 
    12801649      ENDIF 
    12811650 
     
    12851654      CASE ('coupled') 
    12861655         IF ( TRIM(sn_rcv_dqnsdt%clcat) == 'yes' ) THEN 
    1287             dqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl) 
     1656            zdqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl) 
    12881657         ELSE 
    12891658            ! Set all category values equal for the moment 
    12901659            DO jl=1,jpl 
    1291                dqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1) 
     1660               zdqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1) 
    12921661            ENDDO 
    12931662         ENDIF 
    12941663      END SELECT 
    1295  
     1664       
     1665      IF( ln_mixcpl ) THEN 
     1666         DO jl=1,jpl 
     1667            dqns_ice(:,:,jl) = dqns_ice(:,:,jl) * xcplmask(:,:,0) + zdqns_ice(:,:,jl) * zmsk(:,:) 
     1668         ENDDO 
     1669      ELSE 
     1670         dqns_ice(:,:,:) = zdqns_ice(:,:,:) 
     1671      ENDIF 
     1672       
    12961673      !                                                      ! ========================= ! 
    12971674      SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) )             !    topmelt and botmelt    ! 
     
    13091686      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    13101687 
    1311       CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr ) 
     1688      CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
     1689      CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
    13121690      ! 
    13131691      IF( nn_timing == 1 )  CALL timing_stop('sbc_cpl_ice_flx') 
     
    13291707      INTEGER ::   ji, jj, jl   ! dummy loop indices 
    13301708      INTEGER ::   isec, info   ! local integer 
     1709      REAL(wp) ::   zumax, zvmax 
    13311710      REAL(wp), POINTER, DIMENSION(:,:)   ::   zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 
    13321711      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ztmp3, ztmp4    
     
    13451724      !                                                      ! ------------------------- ! 
    13461725      IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN 
    1347          SELECT CASE( sn_snd_temp%cldes) 
    1348          CASE( 'oce only'             )   ;   ztmp1(:,:) =   tsn(:,:,1,jp_tem) + rt0 
    1349          CASE( 'weighted oce and ice' )   ;   ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:)    
    1350             SELECT CASE( sn_snd_temp%clcat ) 
    1351             CASE( 'yes' )    
    1352                ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
    1353             CASE( 'no' ) 
    1354                ztmp3(:,:,:) = 0.0 
     1726          
     1727         IF ( nn_components == jp_iam_opa ) THEN 
     1728            ztmp1(:,:) = tsn(:,:,1,jp_tem)   ! send temperature as it is (potential or conservative) -> use of ln_useCT on the received part 
     1729         ELSE 
     1730            ! we must send the surface potential temperature  
     1731            IF( ln_useCT )  THEN    ;   ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 
     1732            ELSE                    ;   ztmp1(:,:) = tsn(:,:,1,jp_tem) 
     1733            ENDIF 
     1734            ! 
     1735            SELECT CASE( sn_snd_temp%cldes) 
     1736            CASE( 'oce only'             )   ;   ztmp1(:,:) =   ztmp1(:,:) + rt0 
     1737            CASE( 'oce and ice'          )   ;   ztmp1(:,:) =   ztmp1(:,:) + rt0 
     1738               SELECT CASE( sn_snd_temp%clcat ) 
     1739               CASE( 'yes' )    
     1740                  ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) 
     1741               CASE( 'no' ) 
     1742                  WHERE( SUM( a_i, dim=3 ) /= 0. ) 
     1743                     ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
     1744                  ELSEWHERE 
     1745                     ztmp3(:,:,1) = rt0 ! TODO: Is freezing point a good default? (Maybe SST is better?) 
     1746                  END WHERE 
     1747               CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
     1748               END SELECT 
     1749            CASE( 'weighted oce and ice' )   ;   ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:)    
     1750               SELECT CASE( sn_snd_temp%clcat ) 
     1751               CASE( 'yes' )    
     1752                  ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1753               CASE( 'no' ) 
     1754                  ztmp3(:,:,:) = 0.0 
     1755                  DO jl=1,jpl 
     1756                     ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 
     1757                  ENDDO 
     1758               CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
     1759               END SELECT 
     1760            CASE( 'mixed oce-ice'        )    
     1761               ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:)  
    13551762               DO jl=1,jpl 
    1356                   ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 
     1763                  ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) 
    13571764               ENDDO 
    1358             CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
     1765            CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) 
    13591766            END SELECT 
    1360          CASE( 'mixed oce-ice'        )    
    1361             ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:)  
    1362             DO jl=1,jpl 
    1363                ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) 
    1364             ENDDO 
    1365          CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) 
    1366          END SELECT 
     1767         ENDIF 
    13671768         IF( ssnd(jps_toce)%laction )   CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 
    13681769         IF( ssnd(jps_tice)%laction )   CALL cpl_snd( jps_tice, isec, ztmp3, info ) 
     
    13731774      !                                                      ! ------------------------- ! 
    13741775      IF( ssnd(jps_albice)%laction ) THEN                         ! ice  
    1375          ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1776         SELECT CASE( sn_snd_alb%cldes ) 
     1777         CASE( 'ice'          )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
     1778         CASE( 'weighted ice' )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1779         CASE default             ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
     1780         END SELECT 
    13761781         CALL cpl_snd( jps_albice, isec, ztmp3, info ) 
    13771782      ENDIF 
     
    13861791      !                                                      !  Ice fraction & Thickness !  
    13871792      !                                                      ! ------------------------- ! 
    1388       ! Send ice fraction field  
     1793      ! Send ice fraction field to atmosphere 
    13891794      IF( ssnd(jps_fice)%laction ) THEN 
    13901795         SELECT CASE( sn_snd_thick%clcat ) 
     
    13931798         CASE default    ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 
    13941799         END SELECT 
    1395          CALL cpl_snd( jps_fice, isec, ztmp3, info ) 
     1800         IF( ssnd(jps_fice)%laction )   CALL cpl_snd( jps_fice, isec, ztmp3, info ) 
     1801      ENDIF 
     1802       
     1803      ! Send ice fraction field to OPA (sent by SAS in SAS-OPA coupling) 
     1804      IF( ssnd(jps_fice2)%laction ) THEN 
     1805         ztmp3(:,:,1) = fr_i(:,:) 
     1806         IF( ssnd(jps_fice2)%laction )   CALL cpl_snd( jps_fice2, isec, ztmp3, info ) 
    13961807      ENDIF 
    13971808 
     
    14141825            END SELECT 
    14151826         CASE( 'ice and snow'         )    
    1416             ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) 
    1417             ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) 
     1827            SELECT CASE( sn_snd_thick%clcat ) 
     1828            CASE( 'yes' ) 
     1829               ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) 
     1830               ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) 
     1831            CASE( 'no' ) 
     1832               WHERE( SUM( a_i, dim=3 ) /= 0. ) 
     1833                  ztmp3(:,:,1) = SUM( ht_i * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
     1834                  ztmp4(:,:,1) = SUM( ht_s * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
     1835               ELSEWHERE 
     1836                 ztmp3(:,:,1) = 0. 
     1837                 ztmp4(:,:,1) = 0. 
     1838               END WHERE 
     1839            CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 
     1840            END SELECT 
    14181841         CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' ) 
    14191842         END SELECT 
     
    14411864         !                                                              i-1  i   i 
    14421865         !                                                               i      i+1 (for I) 
    1443          SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 
    1444          CASE( 'oce only'             )      ! C-grid ==> T 
    1445             DO jj = 2, jpjm1 
    1446                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1447                   zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj  ,1) ) 
    1448                   zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji  ,jj-1,1) )  
    1449                END DO 
    1450             END DO 
    1451          CASE( 'weighted oce and ice' )    
    1452             SELECT CASE ( cp_ice_msh ) 
    1453             CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T 
     1866         IF( nn_components == jp_iam_opa ) THEN 
     1867            zotx1(:,:) = un(:,:,1)   
     1868            zoty1(:,:) = vn(:,:,1)   
     1869         ELSE         
     1870            SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 
     1871            CASE( 'oce only'             )      ! C-grid ==> T 
    14541872               DO jj = 2, jpjm1 
    14551873                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    1456                      zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   
    1457                      zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj) 
    1458                      zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
    1459                      zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
     1874                     zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj  ,1) ) 
     1875                     zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji  ,jj-1,1) )  
    14601876                  END DO 
    14611877               END DO 
    1462             CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T 
    1463                DO jj = 2, jpjm1 
    1464                   DO ji = 2, jpim1   ! NO vector opt. 
    1465                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   
    1466                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   
    1467                      zitx1(ji,jj) = 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     & 
    1468                         &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1469                      zity1(ji,jj) = 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     & 
    1470                         &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1878            CASE( 'weighted oce and ice' )    
     1879               SELECT CASE ( cp_ice_msh ) 
     1880               CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T 
     1881                  DO jj = 2, jpjm1 
     1882                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     1883                        zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   
     1884                        zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj) 
     1885                        zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
     1886                        zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
     1887                     END DO 
    14711888                  END DO 
    1472                END DO 
    1473             CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
    1474                DO jj = 2, jpjm1 
    1475                   DO ji = 2, jpim1   ! NO vector opt. 
    1476                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   
    1477                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   
    1478                      zitx1(ji,jj) = 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
    1479                         &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1480                      zity1(ji,jj) = 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
    1481                         &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1889               CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T 
     1890                  DO jj = 2, jpjm1 
     1891                     DO ji = 2, jpim1   ! NO vector opt. 
     1892                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   
     1893                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   
     1894                        zitx1(ji,jj) = 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     & 
     1895                           &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1896                        zity1(ji,jj) = 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     & 
     1897                           &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1898                     END DO 
    14821899                  END DO 
    1483                END DO 
     1900               CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
     1901                  DO jj = 2, jpjm1 
     1902                     DO ji = 2, jpim1   ! NO vector opt. 
     1903                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   
     1904                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   
     1905                        zitx1(ji,jj) = 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
     1906                           &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1907                        zity1(ji,jj) = 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
     1908                           &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1909                     END DO 
     1910                  END DO 
     1911               END SELECT 
     1912               CALL lbc_lnk( zitx1, 'T', -1. )   ;   CALL lbc_lnk( zity1, 'T', -1. ) 
     1913            CASE( 'mixed oce-ice'        ) 
     1914               SELECT CASE ( cp_ice_msh ) 
     1915               CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T 
     1916                  DO jj = 2, jpjm1 
     1917                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     1918                        zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   & 
     1919                           &         + 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
     1920                        zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj)   & 
     1921                           &         + 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
     1922                     END DO 
     1923                  END DO 
     1924               CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T 
     1925                  DO jj = 2, jpjm1 
     1926                     DO ji = 2, jpim1   ! NO vector opt. 
     1927                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
     1928                           &         + 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     & 
     1929                           &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1930                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
     1931                           &         + 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     & 
     1932                           &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1933                     END DO 
     1934                  END DO 
     1935               CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
     1936                  DO jj = 2, jpjm1 
     1937                     DO ji = 2, jpim1   ! NO vector opt. 
     1938                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
     1939                           &         + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
     1940                           &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1941                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
     1942                           &         + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
     1943                           &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
     1944                     END DO 
     1945                  END DO 
     1946               END SELECT 
    14841947            END SELECT 
    1485             CALL lbc_lnk( zitx1, 'T', -1. )   ;   CALL lbc_lnk( zity1, 'T', -1. ) 
    1486          CASE( 'mixed oce-ice'        ) 
    1487             SELECT CASE ( cp_ice_msh ) 
    1488             CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T 
    1489                DO jj = 2, jpjm1 
    1490                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    1491                      zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   & 
    1492                         &         + 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
    1493                      zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj)   & 
    1494                         &         + 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
    1495                   END DO 
    1496                END DO 
    1497             CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T 
    1498                DO jj = 2, jpjm1 
    1499                   DO ji = 2, jpim1   ! NO vector opt. 
    1500                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
    1501                         &         + 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     & 
    1502                         &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1503                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
    1504                         &         + 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     & 
    1505                         &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1506                   END DO 
    1507                END DO 
    1508             CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
    1509                DO jj = 2, jpjm1 
    1510                   DO ji = 2, jpim1   ! NO vector opt. 
    1511                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
    1512                         &         + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
    1513                         &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1514                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
    1515                         &         + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
    1516                         &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
    1517                   END DO 
    1518                END DO 
    1519             END SELECT 
    1520          END SELECT 
    1521          CALL lbc_lnk( zotx1, ssnd(jps_ocx1)%clgrid, -1. )   ;   CALL lbc_lnk( zoty1, ssnd(jps_ocy1)%clgrid, -1. ) 
     1948            CALL lbc_lnk( zotx1, ssnd(jps_ocx1)%clgrid, -1. )   ;   CALL lbc_lnk( zoty1, ssnd(jps_ocy1)%clgrid, -1. ) 
     1949            ! 
     1950         ENDIF 
    15221951         ! 
    15231952         ! 
     
    15591988      ENDIF 
    15601989      ! 
     1990      ! 
     1991      !  Fields sent by OPA to SAS when doing OPA<->SAS coupling 
     1992      !                                                        ! SSH 
     1993      IF( ssnd(jps_ssh )%laction )  THEN 
     1994         !                          ! removed inverse barometer ssh when Patm 
     1995         !                          forcing is used (for sea-ice dynamics) 
     1996         IF( ln_apr_dyn ) THEN   ;   ztmp1(:,:) = sshb(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) 
     1997         ELSE                    ;   ztmp1(:,:) = sshn(:,:) 
     1998         ENDIF 
     1999         CALL cpl_snd( jps_ssh   , isec, RESHAPE ( ztmp1            , (/jpi,jpj,1/) ), info ) 
     2000 
     2001      ENDIF 
     2002      !                                                        ! SSS 
     2003      IF( ssnd(jps_soce  )%laction )  THEN 
     2004         CALL cpl_snd( jps_soce  , isec, RESHAPE ( tsn(:,:,1,jp_sal), (/jpi,jpj,1/) ), info ) 
     2005      ENDIF 
     2006      !                                                        ! first T level thickness  
     2007      IF( ssnd(jps_e3t1st )%laction )  THEN 
     2008         CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( fse3t_n(:,:,1)   , (/jpi,jpj,1/) ), info ) 
     2009      ENDIF 
     2010      !                                                        ! Qsr fraction 
     2011      IF( ssnd(jps_fraqsr)%laction )  THEN 
     2012         CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(:,:) , (/jpi,jpj,1/) ), info ) 
     2013      ENDIF 
     2014      ! 
     2015      !  Fields sent by SAS to OPA when OASIS coupling 
     2016      !                                                        ! Solar heat flux 
     2017      IF( ssnd(jps_qsroce)%laction )  CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr , (/jpi,jpj,1/) ), info ) 
     2018      IF( ssnd(jps_qnsoce)%laction )  CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns , (/jpi,jpj,1/) ), info ) 
     2019      IF( ssnd(jps_oemp  )%laction )  CALL cpl_snd( jps_oemp  , isec, RESHAPE ( emp , (/jpi,jpj,1/) ), info ) 
     2020      IF( ssnd(jps_sflx  )%laction )  CALL cpl_snd( jps_sflx  , isec, RESHAPE ( sfx , (/jpi,jpj,1/) ), info ) 
     2021      IF( ssnd(jps_otx1  )%laction )  CALL cpl_snd( jps_otx1  , isec, RESHAPE ( utau, (/jpi,jpj,1/) ), info ) 
     2022      IF( ssnd(jps_oty1  )%laction )  CALL cpl_snd( jps_oty1  , isec, RESHAPE ( vtau, (/jpi,jpj,1/) ), info ) 
     2023      IF( ssnd(jps_rnf   )%laction )  CALL cpl_snd( jps_rnf   , isec, RESHAPE ( rnf , (/jpi,jpj,1/) ), info ) 
     2024      IF( ssnd(jps_taum  )%laction )  CALL cpl_snd( jps_taum  , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info ) 
     2025 
    15612026      CALL wrk_dealloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 ) 
    15622027      CALL wrk_dealloc( jpi,jpj,jpl, ztmp3, ztmp4 ) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r5038 r5620  
    88   !!            3.0  ! 2006-08  (G. Madec)  Surface module 
    99   !!            3.2  ! 2009-07  (C. Talandier) emp mean s spread over erp area  
     10   !!            3.6  ! 2014-11  (P. Mathiot  ) add ice shelf melting 
    1011   !!---------------------------------------------------------------------- 
    1112 
     
    8889         ! 
    8990         IF( kn_fwb == 3 .AND. nn_sssr /= 2 )   CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' ) 
    90          ! 
    91          area = glob_sum( e1e2t(:,:) )           ! interior global domain surface 
     91         IF( kn_fwb == 3 .AND. ln_isfcav    )   CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 with ln_isfcav = .TRUE. not working, we stop ' ) 
     92         ! 
     93         area = glob_sum( e1e2t(:,:) * tmask(:,:,1))           ! interior global domain surface 
     94         ! isf cavities are excluded because it can feedback to the melting with generation of inhibition of plumes 
     95         ! and in case of no melt, it can generate HSSW. 
    9296         ! 
    9397#if ! defined key_lim2 &&  ! defined key_lim3 && ! defined key_cice 
     
    106110            z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) -  snwice_fmass(:,:) ) ) / area   ! sum over the global domain 
    107111            zcoef = z_fwf * rcp 
    108             emp(:,:) = emp(:,:) - z_fwf  
    109             qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) ! account for change to the heat budget due to fw correction 
     112            emp(:,:) = emp(:,:) - z_fwf              * tmask(:,:,1) 
     113            qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction 
    110114         ENDIF 
    111115         ! 
     
    138142         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN         ! correct the freshwater fluxes 
    139143            zcoef = fwfold * rcp 
    140             emp(:,:) = emp(:,:) + fwfold 
    141             qns(:,:) = qns(:,:) - zcoef * sst_m(:,:) ! account for change to the heat budget due to fw correction 
     144            emp(:,:) = emp(:,:) + fwfold             * tmask(:,:,1) 
     145            qns(:,:) = qns(:,:) - zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction 
    142146         ENDIF 
    143147         ! 
     
    158162            zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) ) 
    159163            !                                                  ! fwf global mean (excluding ocean to ice/snow exchanges)  
    160             z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - snwice_fmass(:,:) ) ) / area 
     164            z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 
    161165            !             
    162166            IF( z_fwf < 0._wp ) THEN         ! spread out over >0 erp area to increase evaporation 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    4040# if defined key_cice4 
    4141   USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow,  & 
     42                strocnxT,strocnyT,                               &  
    4243                sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm,     & 
    4344                fresh_gbm,fhocn_gbm,fswthru_gbm,frzmlt,          & 
     
    4849#else 
    4950   USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow,  & 
     51                strocnxT,strocnyT,                               &  
    5052                sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai,     & 
    5153                fresh_ai,fhocn_ai,fswthru_ai,frzmlt,          & 
     
    9496#  include "domzgr_substitute.h90" 
    9597 
     98   !! $Id$ 
    9699CONTAINS 
    97100 
     
    135138         IF      ( ksbc == jp_flx ) THEN 
    136139            CALL cice_sbc_force(kt) 
    137          ELSE IF ( ksbc == jp_cpl ) THEN 
     140         ELSE IF ( ksbc == jp_purecpl ) THEN 
    138141            CALL sbc_cpl_ice_flx( 1.0-fr_i  ) 
    139142         ENDIF 
     
    143146         CALL cice_sbc_out ( kt, ksbc ) 
    144147 
    145          IF ( ksbc == jp_cpl )  CALL cice_sbc_hadgam(kt+1) 
     148         IF ( ksbc == jp_purecpl )  CALL cice_sbc_hadgam(kt+1) 
    146149 
    147150      ENDIF                                          ! End sea-ice time step only 
     
    184187 
    185188! Do some CICE consistency checks 
    186       IF ( (ksbc == jp_flx) .OR. (ksbc == jp_cpl) ) THEN 
     189      IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN 
    187190         IF ( calc_strair .OR. calc_Tsfc ) THEN 
    188191            CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=F and calc_Tsfc=F in ice_in' ) 
     
    209212 
    210213      CALL cice2nemo(aice,fr_i, 'T', 1. ) 
    211       IF ( (ksbc == jp_flx) .OR. (ksbc == jp_cpl) ) THEN 
     214      IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN 
    212215         DO jl=1,ncat 
    213216            CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) 
     
    316319! forced and coupled case  
    317320 
    318       IF ( (ksbc == jp_flx).OR.(ksbc == jp_cpl) ) THEN 
     321      IF ( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN 
    319322 
    320323         ztmpn(:,:,:)=0.0 
     
    506509      CALL nemo2cice(ztmp,ss_tlty,'F', -1. ) 
    507510 
    508       CALL wrk_dealloc( jpi,jpj, ztmp ) 
     511      CALL wrk_dealloc( jpi,jpj, ztmp, zpice ) 
    509512      CALL wrk_dealloc( jpi,jpj,ncat, ztmpn ) 
    510513      ! 
     
    560563! Combine wind stress and ocean-ice stress 
    561564! [Note that fr_iu hasn't yet been updated, so still from start of CICE timestep] 
     565! strocnx and strocny already weighted by ice fraction in CICE so not done here  
    562566 
    563567      utau(:,:)=(1.0-fr_iu(:,:))*utau(:,:)-ss_iou(:,:) 
    564568      vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:)      
     569  
     570! Also need ice/ocean stress on T points so that taum can be updated  
     571! This interpolation is already done in CICE so best to use those values  
     572      CALL cice2nemo(strocnxT,ztmp1,'T',-1.)  
     573      CALL cice2nemo(strocnyT,ztmp2,'T',-1.)  
     574  
     575! Update taum with modulus of ice-ocean stress  
     576! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here  
     577taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1**2. + ztmp2**2.)  
    565578 
    566579! Freshwater fluxes  
     
    574587      ELSE IF (ksbc == jp_core) THEN 
    575588         emp(:,:)  = (1.0-fr_i(:,:))*emp(:,:)         
    576       ELSE IF (ksbc == jp_cpl) THEN 
     589      ELSE IF (ksbc == jp_purecpl) THEN 
    577590! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above)  
    578591! This is currently as required with the coupling fields from the UM atmosphere 
     
    610623      ENDIF 
    611624! Take into account snow melting except for fully coupled when already in qns_tot 
    612       IF (ksbc == jp_cpl) THEN 
     625      IF (ksbc == jp_purecpl) THEN 
    613626         qsr(:,:)= qsr_tot(:,:) 
    614627         qns(:,:)= qns_tot(:,:) 
     
    645658 
    646659      CALL cice2nemo(aice,fr_i,'T', 1. ) 
    647       IF ( (ksbc == jp_flx).OR.(ksbc == jp_cpl) ) THEN 
     660      IF ( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN 
    648661         DO jl=1,ncat 
    649662            CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) 
     
    10831096   !!   Default option           Dummy module         NO CICE sea-ice model 
    10841097   !!---------------------------------------------------------------------- 
     1098   !! $Id$ 
    10851099CONTAINS 
    10861100 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90

    r5038 r5620  
    103103                                 ! ( d rho / dt ) / ( d rho / ds )      ( s = 34, t = -1.8 ) 
    104104          
    105          fr_i(:,:) = eos_fzp( sss_m ) * tmask(:,:,1)      ! sea surface freezing temperature [Celcius] 
     105         CALL eos_fzp( sss_m(:,:), fr_i(:,:) )       ! sea surface freezing temperature [Celcius] 
     106         fr_i(:,:) = fr_i(:,:) * tmask(:,:,1) 
    106107 
    107          IF( lk_cpl )   a_i(:,:,1) = fr_i(:,:)          
     108         IF( ln_cpl )   a_i(:,:,1) = fr_i(:,:)          
    108109 
    109110         ! Flux and ice fraction computation 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r5038 r5620  
    1919   !!---------------------------------------------------------------------- 
    2020   !!   sbc_ice_lim  : sea-ice model time-stepping and update ocean sbc over ice-covered area 
    21    !!   lim_ctl       : alerts in case of ice model crash 
    22    !!   lim_prt_state : ice control print at a given grid point 
    2321   !!---------------------------------------------------------------------- 
    2422   USE oce             ! ocean dynamics and tracers 
    2523   USE dom_oce         ! ocean space and time domain 
    26    USE par_ice         ! sea-ice parameters 
    2724   USE ice             ! LIM-3: ice variables 
    28    USE iceini          ! LIM-3: ice initialisation 
     25   USE thd_ice         ! LIM-3: thermodynamical variables 
    2926   USE dom_ice         ! LIM-3: ice domain 
    3027 
     
    4037   USE limdyn          ! Ice dynamics 
    4138   USE limtrp          ! Ice transport 
     39   USE limhdf          ! Ice horizontal diffusion 
    4240   USE limthd          ! Ice thermodynamics 
    43    USE limitd_th       ! Thermodynamics on ice thickness distribution  
    4441   USE limitd_me       ! Mechanics on ice thickness distribution 
    4542   USE limsbc          ! sea surface boundary condition 
     
    4744   USE limwri          ! Ice outputs 
    4845   USE limrst          ! Ice restarts 
    49    USE limupdate1       ! update of global variables 
    50    USE limupdate2       ! update of global variables 
     46   USE limupdate1      ! update of global variables 
     47   USE limupdate2      ! update of global variables 
    5148   USE limvar          ! Ice variables switch 
     49 
     50   USE limmsh          ! LIM mesh 
     51   USE limistate       ! LIM initial state 
     52   USE limthd_sal      ! LIM ice thermodynamics: salinity 
    5253 
    5354   USE c1d             ! 1D vertical configuration 
     
    6061   USE prtctl          ! Print control 
    6162   USE lib_fortran     !  
    62    USE cpl_oasis3, ONLY : lk_cpl 
     63   USE limctl 
    6364 
    6465#if defined key_bdy  
     
    7071 
    7172   PUBLIC sbc_ice_lim  ! routine called by sbcmod.F90 
    72    PUBLIC lim_prt_state 
     73   PUBLIC sbc_lim_init ! routine called by sbcmod.F90 
    7374    
    7475   !! * Substitutions 
     
    107108      INTEGER, INTENT(in) ::   kblk    ! type of bulk (=3 CLIO, =4 CORE, =5 COUPLED) 
    108109      !! 
    109       INTEGER  ::   ji, jj, jl, jk      ! dummy loop index 
    110       REAL(wp) ::   zcoef   ! local scalar 
     110      INTEGER  ::   jl                 ! dummy loop index 
    111111      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_os, zalb_cs  ! ice albedo under overcast/clear sky 
    112112      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_ice          ! mean ice albedo (for coupled) 
     113      REAL(wp), POINTER, DIMENSION(:,:  )   ::   zutau_ice, zvtau_ice  
    113114      !!---------------------------------------------------------------------- 
    114115 
    115116      IF( nn_timing == 1 )  CALL timing_start('sbc_ice_lim') 
    116117 
    117       IF( kt == nit000 ) THEN 
    118          IF(lwp) WRITE(numout,*) 
    119          IF(lwp) WRITE(numout,*) 'sbc_ice_lim : update ocean surface boudary condition'  
    120          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   via Louvain la Neuve Ice Model (LIM-3) time stepping' 
    121          ! 
    122          CALL ice_init 
    123          ! 
    124          IF( ln_nicep ) THEN      ! control print at a given point 
    125             jiindx = 15    ;   jjindx =  44 
    126             IF(lwp) WRITE(numout,*) ' The debugging point is : jiindx : ',jiindx, ' jjindx : ',jjindx 
    127          ENDIF 
    128       ENDIF 
    129  
    130       !                                        !----------------------! 
    131       IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !  Ice time-step only  ! 
    132          !                                     !----------------------! 
    133          !                                           !  Bulk Formulae ! 
    134          !                                           !----------------! 
    135          ! 
    136          u_oce(:,:) = ssu_m(:,:) * umask(:,:,1)                     ! mean surface ocean current at ice velocity point 
    137          v_oce(:,:) = ssv_m(:,:) * vmask(:,:,1)                    ! (C-grid dynamics :  U- & V-points as the ocean) 
    138          ! 
    139          t_bo(:,:) = ( eos_fzp( sss_m ) +  rt0 ) * tmask(:,:,1) + rt0 * ( 1. - tmask(:,:,1) )  ! masked sea surface freezing temperature [Kelvin] 
    140          !                                                                                  ! (set to rt0 over land) 
    141          !                                           ! Ice albedo 
    142          CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice )       
    143  
    144          CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os )  ! cloud-sky and overcast-sky ice albedos 
    145  
     118      !-----------------------! 
     119      ! --- Ice time step --- ! 
     120      !-----------------------! 
     121      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 
     122 
     123         ! mean surface ocean current at ice velocity point (C-grid dynamics :  U- & V-points as the ocean) 
     124         u_oce(:,:) = ssu_m(:,:) * umask(:,:,1) 
     125         v_oce(:,:) = ssv_m(:,:) * vmask(:,:,1) 
     126          
     127         ! masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
     128         CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) 
     129         t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 
     130           
     131         ! Mask sea ice surface temperature (set to rt0 over land) 
     132         DO jl = 1, jpl 
     133            t_su(:,:,jl) = t_su(:,:,jl) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 
     134         END DO      
     135         ! 
     136         !------------------------------------------------!                                            
     137         ! --- Dynamical coupling with the atmosphere --- !                                            
     138         !------------------------------------------------! 
     139         ! It provides the following fields: 
     140         ! utau_ice, vtau_ice : surface ice stress (U- & V-points)   [N/m2] 
     141         !----------------------------------------------------------------- 
    146142         SELECT CASE( kblk ) 
    147          CASE( jp_core , jp_cpl )   ! CORE and COUPLED bulk formulations 
    148  
    149             ! albedo depends on cloud fraction because of non-linear spectral effects 
    150             zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    151             ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo  
    152             ! (zalb_ice) is computed within the bulk routine 
    153              
     143         CASE( jp_clio    )   ;   CALL blk_ice_clio_tau                         ! CLIO bulk formulation             
     144         CASE( jp_core    )   ;   CALL blk_ice_core_tau                         ! CORE bulk formulation 
     145         CASE( jp_purecpl )   ;   CALL sbc_cpl_ice_tau( utau_ice , vtau_ice )   ! Coupled   formulation 
    154146         END SELECT 
    155147          
    156          !                                           ! Mask sea ice surface temperature 
    157          DO jl = 1, jpl 
    158             t_su(:,:,jl) = t_su(:,:,jl) +  rt0 * ( 1. - tmask(:,:,1) ) 
    159          END DO 
    160       
    161          ! Bulk formulae  - provides the following fields: 
    162          ! utau_ice, vtau_ice : surface ice stress                     (U- & V-points)   [N/m2] 
     148         IF( ln_mixcpl) THEN   ! Case of a mixed Bulk/Coupled formulation 
     149            CALL wrk_alloc( jpi,jpj    , zutau_ice, zvtau_ice) 
     150            CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) 
     151            utau_ice(:,:) = utau_ice(:,:) * xcplmask(:,:,0) + zutau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 
     152            vtau_ice(:,:) = vtau_ice(:,:) * xcplmask(:,:,0) + zvtau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 
     153            CALL wrk_dealloc( jpi,jpj  , zutau_ice, zvtau_ice) 
     154         ENDIF 
     155 
     156         !-------------------------------------------------------! 
     157         ! --- ice dynamics and transport (except in 1D case) ---! 
     158         !-------------------------------------------------------! 
     159         numit = numit + nn_fsbc                  ! Ice model time step 
     160         !                                                    
     161         CALL sbc_lim_bef                         ! Store previous ice values 
     162         CALL sbc_lim_diag0                       ! set diag of mass, heat and salt fluxes to 0 
     163         CALL lim_rst_opn( kt )                   ! Open Ice restart file 
     164         ! 
     165         IF( .NOT. lk_c1d ) THEN 
     166            ! 
     167            CALL lim_dyn( kt )                    ! Ice dynamics    ( rheology/dynamics )    
     168            ! 
     169            CALL lim_trp( kt )                    ! Ice transport   ( Advection/diffusion ) 
     170            ! 
     171            IF( nn_monocat /= 2 ) CALL lim_itd_me ! Mechanical redistribution ! (ridging/rafting) 
     172            ! 
     173#if defined key_bdy 
     174            CALL bdy_ice_lim( kt )                ! bdy ice thermo  
     175            IF( ln_icectl )       CALL lim_prt( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) 
     176#endif 
     177            ! 
     178            CALL lim_update1( kt )                ! Corrections 
     179            ! 
     180         ENDIF 
     181          
     182         ! previous lead fraction and ice volume for flux calculations 
     183         CALL sbc_lim_bef                         
     184         CALL lim_var_glo2eqv                     ! ht_i and ht_s for ice albedo calculation 
     185         CALL lim_var_agg(1)                      ! at_i for coupling (via pfrld)  
     186         pfrld(:,:)   = 1._wp - at_i(:,:) 
     187         phicif(:,:)  = vt_i(:,:) 
     188          
     189         !------------------------------------------------------!                                            
     190         ! --- Thermodynamical coupling with the atmosphere --- !                                            
     191         !------------------------------------------------------! 
     192         ! It provides the following fields: 
    163193         ! qsr_ice , qns_ice  : solar & non solar heat flux over ice   (T-point)         [W/m2] 
    164194         ! qla_ice            : latent heat flux over ice              (T-point)         [W/m2] 
     
    166196         ! tprecip , sprecip  : total & solid precipitation            (T-point)         [Kg/m2/s] 
    167197         ! fr1_i0  , fr2_i0   : 1sr & 2nd fraction of qsr penetration in ice             [%] 
    168          ! 
     198         !---------------------------------------------------------------------------------------- 
     199         CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     200         CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 
     201 
    169202         SELECT CASE( kblk ) 
    170203         CASE( jp_clio )                                       ! CLIO bulk formulation 
    171             CALL blk_ice_clio( t_su , zalb_cs    , zalb_os    , zalb_ice  ,               & 
    172                &                      utau_ice   , vtau_ice   , qns_ice   , qsr_ice   ,   & 
    173                &                      qla_ice    , dqns_ice   , dqla_ice  ,               & 
    174                &                      tprecip    , sprecip    ,                           & 
    175                &                      fr1_i0     , fr2_i0     , cp_ice_msh, jpl  ) 
    176             !          
    177             IF( nn_limflx /= 2 )   CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice ,   & 
    178                &                                           dqns_ice, qla_ice, dqla_ice, nn_limflx ) 
    179  
     204            ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo  
     205            ! (zalb_ice) is computed within the bulk routine 
     206            CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice ) 
     207            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
     208            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    180209         CASE( jp_core )                                       ! CORE bulk formulation 
    181             CALL blk_ice_core( t_su , u_ice     , v_ice     , zalb_ice   ,               & 
    182                &                      utau_ice  , vtau_ice  , qns_ice    , qsr_ice   ,   & 
    183                &                      qla_ice   , dqns_ice  , dqla_ice   ,               & 
    184                &                      tprecip   , sprecip   ,                            & 
    185                &                      fr1_i0    , fr2_i0    , cp_ice_msh, jpl  ) 
    186                ! 
    187             IF( nn_limflx /= 2 )   CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice ,   & 
    188                &                                           dqns_ice, qla_ice, dqla_ice, nn_limflx ) 
    189             ! 
    190          CASE ( jp_cpl ) 
    191              
    192             CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) 
    193  
    194             ! MV -> seb  
    195 !           CALL sbc_cpl_ice_flx( p_frld=ato_i, palbi=zalb_ice, psst=sst_m, pist=t_su    ) 
    196  
    197 !           IF( nn_limflx == 2 )   CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice ,   & 
    198 !              &                                           dqns_ice, qla_ice, dqla_ice, nn_limflx ) 
    199 !           ! Latent heat flux is forced to 0 in coupled : 
    200 !           !  it is included in qns (non-solar heat flux) 
    201 !           qla_ice  (:,:,:) = 0._wp 
    202 !           dqla_ice (:,:,:) = 0._wp 
    203             ! END MV -> seb 
    204             ! 
     210            ! albedo depends on cloud fraction because of non-linear spectral effects 
     211            zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     212            CALL blk_ice_core_flx( t_su, zalb_ice ) 
     213            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
     214            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     215         CASE ( jp_purecpl ) 
     216            ! albedo depends on cloud fraction because of non-linear spectral effects 
     217            zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     218                                 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
     219            ! clem: evap_ice is forced to 0 in coupled mode for now  
     220            !       but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 
     221            evap_ice  (:,:,:) = 0._wp   ;   devap_ice (:,:,:) = 0._wp 
     222            IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    205223         END SELECT 
    206           
    207          !                                           !----------------------! 
    208          !                                           ! LIM-3  time-stepping ! 
    209          !                                           !----------------------! 
    210          !  
    211          numit = numit + nn_fsbc                     ! Ice model time step 
    212          ! 
    213          !                                           ! Store previous ice values 
    214          a_i_b  (:,:,:)   = a_i  (:,:,:)     ! ice area 
    215          e_i_b  (:,:,:,:) = e_i  (:,:,:,:)   ! ice thermal energy 
    216          v_i_b  (:,:,:)   = v_i  (:,:,:)     ! ice volume 
    217          v_s_b  (:,:,:)   = v_s  (:,:,:)     ! snow volume  
    218          e_s_b  (:,:,:,:) = e_s  (:,:,:,:)   ! snow thermal energy 
    219          smv_i_b(:,:,:)   = smv_i(:,:,:)     ! salt content 
    220          oa_i_b (:,:,:)   = oa_i (:,:,:)     ! areal age content 
    221          u_ice_b(:,:)     = u_ice(:,:) 
    222          v_ice_b(:,:)     = v_ice(:,:) 
    223  
    224          ! salt, heat and mass fluxes 
    225          sfx    (:,:) = 0._wp   ; 
    226          sfx_bri(:,:) = 0._wp   ;  
    227          sfx_sni(:,:) = 0._wp   ;   sfx_opw(:,:) = 0._wp 
    228          sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
    229          sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
    230          sfx_res(:,:) = 0._wp 
    231  
    232          wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
    233          wfx_sni(:,:) = 0._wp   ;   wfx_opw(:,:) = 0._wp 
    234          wfx_bog(:,:) = 0._wp   ;   wfx_dyn(:,:) = 0._wp 
    235          wfx_bom(:,:) = 0._wp   ;   wfx_sum(:,:) = 0._wp 
    236          wfx_res(:,:) = 0._wp   ;   wfx_sub(:,:) = 0._wp 
    237          wfx_spr(:,:) = 0._wp   ;    
    238  
    239          hfx_in (:,:) = 0._wp   ;   hfx_out(:,:) = 0._wp 
    240          hfx_thd(:,:) = 0._wp   ;    
    241          hfx_snw(:,:) = 0._wp   ;   hfx_opw(:,:) = 0._wp 
    242          hfx_bog(:,:) = 0._wp   ;   hfx_dyn(:,:) = 0._wp 
    243          hfx_bom(:,:) = 0._wp   ;   hfx_sum(:,:) = 0._wp 
    244          hfx_res(:,:) = 0._wp   ;   hfx_sub(:,:) = 0._wp 
    245          hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
    246          hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
    247  
    248                           CALL lim_rst_opn( kt )     ! Open Ice restart file 
    249          ! 
    250          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 1, ' - Beginning the time step - ' )   ! control print 
    251          ! ---------------------------------------------- 
    252          ! ice dynamics and transport (except in 1D case) 
    253          ! ---------------------------------------------- 
    254          IF( .NOT. lk_c1d ) THEN 
    255                           CALL lim_dyn( kt )              ! Ice dynamics    ( rheology/dynamics ) 
    256                           CALL lim_trp( kt )              ! Ice transport   ( Advection/diffusion ) 
    257                           CALL lim_var_glo2eqv            ! equivalent variables, requested for rafting 
    258          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx,-1, ' - ice dyn & trp - ' )   ! control print 
    259                           CALL lim_itd_me                 ! Mechanical redistribution ! (ridging/rafting) 
    260                           CALL lim_var_agg( 1 )  
    261 #if defined key_bdy 
    262                           ! bdy ice thermo  
    263                           CALL lim_var_glo2eqv            ! equivalent variables 
    264                           CALL bdy_ice_lim( kt ) 
    265                           CALL lim_itd_me_zapsmall 
    266                           CALL lim_var_agg(1) 
    267          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 1, ' - ice thermo bdy - ' )   ! control print 
    268 #endif 
    269                           CALL lim_update1 
    270          ENDIF 
    271 !                         !- Change old values for new values 
    272                           u_ice_b(:,:)     = u_ice(:,:) 
    273                           v_ice_b(:,:)     = v_ice(:,:) 
    274                           a_i_b  (:,:,:)   = a_i  (:,:,:) 
    275                           v_s_b  (:,:,:)   = v_s  (:,:,:) 
    276                           v_i_b  (:,:,:)   = v_i  (:,:,:) 
    277                           e_s_b  (:,:,:,:) = e_s  (:,:,:,:) 
    278                           e_i_b  (:,:,:,:) = e_i  (:,:,:,:) 
    279                           oa_i_b (:,:,:)   = oa_i (:,:,:) 
    280                           smv_i_b(:,:,:)   = smv_i(:,:,:) 
    281   
    282          ! ---------------------------------------------- 
    283          ! ice thermodynamic 
    284          ! ---------------------------------------------- 
    285                           CALL lim_var_glo2eqv            ! equivalent variables 
    286                           CALL lim_var_agg(1)             ! aggregate ice categories 
    287                           ! previous lead fraction and ice volume for flux calculations 
    288                           pfrld(:,:)   = 1._wp - at_i(:,:) 
    289                           phicif(:,:)  = vt_i(:,:) 
    290  
    291                           ! MV -> seb 
    292                           SELECT CASE( kblk ) 
    293                              CASE ( jp_cpl ) 
    294                              CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su    ) 
    295                              IF( nn_limflx == 2 )   CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice ,   & 
    296                           &                                           dqns_ice, qla_ice, dqla_ice, nn_limflx ) 
    297                            ! Latent heat flux is forced to 0 in coupled : 
    298                            !  it is included in qns (non-solar heat flux) 
    299                              qla_ice  (:,:,:) = 0._wp 
    300                              dqla_ice (:,:,:) = 0._wp 
    301                           END SELECT 
    302                           ! END MV -> seb 
    303                           ! 
    304                           CALL lim_var_bv                 ! bulk brine volume (diag) 
    305                           CALL lim_thd( kt )              ! Ice thermodynamics  
    306                           zcoef = rdt_ice /rday           !  Ice natural aging 
    307                           oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * zcoef 
    308          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 1, ' - ice thermodyn. - ' )   ! control print 
    309                           CALL lim_itd_th( kt )           !  Remap ice categories, lateral accretion  ! 
    310                           CALL lim_var_agg( 1 )           ! requested by limupdate 
    311                           CALL lim_update2                ! Global variables update 
    312  
    313                           CALL lim_var_glo2eqv            ! equivalent variables (outputs) 
    314                           CALL lim_var_agg(2)             ! aggregate ice thickness categories 
    315          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 2, ' - Final state - ' )   ! control print 
    316          ! 
    317                           CALL lim_sbc_flx( kt )     ! Update surface ocean mass, heat and salt fluxes 
    318          ! 
    319          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 3, ' - Final state lim_sbc - ' )   ! control print 
    320          ! 
    321          !                                           ! Diagnostics and outputs  
    322          IF (ln_limdiaout) CALL lim_diahsb 
    323  
    324                           CALL lim_wri( 1  )              ! Ice outputs  
    325  
     224         CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     225 
     226         !----------------------------! 
     227         ! --- ice thermodynamics --- ! 
     228         !----------------------------! 
     229         CALL lim_thd( kt )                         ! Ice thermodynamics       
     230         ! 
     231         CALL lim_update2( kt )                     ! Corrections 
     232         ! 
     233         CALL lim_sbc_flx( kt )                     ! Update surface ocean mass, heat and salt fluxes 
     234         ! 
     235         IF(ln_limdiaout) CALL lim_diahsb           ! Diagnostics and outputs  
     236         ! 
     237         CALL lim_wri( 1 )                          ! Ice outputs  
     238         ! 
    326239         IF( kt == nit000 .AND. ln_rstart )   & 
    327             &             CALL iom_close( numrir )        ! clem: close input ice restart file 
    328          ! 
    329          IF( lrst_ice )   CALL lim_rst_write( kt )        ! Ice restart file  
    330                           CALL lim_var_glo2eqv            ! ??? 
    331          ! 
    332          IF( ln_nicep )   CALL lim_ctl( kt )              ! alerts in case of model crash 
    333          ! 
    334          CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
    335          ! 
    336       ENDIF                                    ! End sea-ice time step only 
    337  
    338       !                                        !--------------------------! 
    339       !                                        !  at all ocean time step  ! 
    340       !                                        !--------------------------! 
    341       !                                                
    342       !                                              ! Update surface ocean stresses (only in ice-dynamic case) 
    343       !                                                   ! otherwise the atm.-ocean stresses are used everywhere 
     240            &             CALL iom_close( numrir )  ! close input ice restart file 
     241         ! 
     242         IF( lrst_ice )   CALL lim_rst_write( kt )  ! Ice restart file  
     243         ! 
     244         IF( ln_icectl )  CALL lim_ctl( kt )        ! alerts in case of model crash 
     245         ! 
     246      ENDIF   ! End sea-ice time step only 
     247 
     248      !-------------------------! 
     249      ! --- Ocean time step --- ! 
     250      !-------------------------! 
     251      ! Update surface ocean stresses (only in ice-dynamic case) otherwise the atm.-ocean stresses are used everywhere 
    344252      IF( ln_limdyn )     CALL lim_sbc_tau( kt, ub(:,:,1), vb(:,:,1) )  ! using before instantaneous surf. currents 
    345253!!gm   remark, the ocean-ice stress is not saved in ice diag call above .....  find a solution!!! 
    346  
    347       ! 
    348       IF( nn_timing == 1 )  CALL timing_stop('sbc_ice_lim') 
     254      ! 
     255      IF( nn_timing == 1 ) CALL timing_stop('sbc_ice_lim') 
    349256      ! 
    350257   END SUBROUTINE sbc_ice_lim 
    351258    
     259 
     260   SUBROUTINE sbc_lim_init 
     261      !!---------------------------------------------------------------------- 
     262      !!                  ***  ROUTINE sbc_lim_init  *** 
     263      !! 
     264      !! ** purpose :   Allocate all the dynamic arrays of the LIM-3 modules 
     265      !!---------------------------------------------------------------------- 
     266      INTEGER :: ierr 
     267      !!---------------------------------------------------------------------- 
     268      IF(lwp) WRITE(numout,*) 
     269      IF(lwp) WRITE(numout,*) 'sbc_ice_lim : update ocean surface boudary condition'  
     270      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   via Louvain la Neuve Ice Model (LIM-3) time stepping' 
     271      ! 
     272                                       ! Open the reference and configuration namelist files and namelist output file  
     273      CALL ctl_opn( numnam_ice_ref, 'namelist_ice_ref',    'OLD',     'FORMATTED', 'SEQUENTIAL', -1, numout, lwp )  
     274      CALL ctl_opn( numnam_ice_cfg, 'namelist_ice_cfg',    'OLD',     'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
     275      IF(lwm) CALL ctl_opn( numoni, 'output.namelist.ice', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, 1 ) 
     276 
     277      CALL ice_run                     ! set some ice run parameters 
     278      ! 
     279      !                                ! Allocate the ice arrays 
     280      ierr =        ice_alloc        ()      ! ice variables 
     281      ierr = ierr + dom_ice_alloc    ()      ! domain 
     282      ierr = ierr + sbc_ice_alloc    ()      ! surface forcing 
     283      ierr = ierr + thd_ice_alloc    ()      ! thermodynamics 
     284      ierr = ierr + lim_itd_me_alloc ()      ! ice thickness distribution - mechanics 
     285      ! 
     286      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
     287      IF( ierr /= 0 )   CALL ctl_stop('STOP', 'sbc_lim_init : unable to allocate ice arrays') 
     288      ! 
     289      !                                ! adequation jpk versus ice/snow layers/categories 
     290      IF( jpl > jpk .OR. (nlay_i+1) > jpk .OR. nlay_s > jpk )   & 
     291         &      CALL ctl_stop( 'STOP',                          & 
     292         &     'sbc_lim_init: the 3rd dimension of workspace arrays is too small.',   & 
     293         &     'use more ocean levels or less ice/snow layers/categories.' ) 
     294      ! 
     295      CALL lim_itd_init                ! ice thickness distribution initialization 
     296      ! 
     297      CALL lim_hdf_init                ! set ice horizontal diffusion computation parameters 
     298      ! 
     299      CALL lim_thd_init                ! set ice thermodynics parameters 
     300      ! 
     301      CALL lim_thd_sal_init            ! set ice salinity parameters 
     302      ! 
     303      CALL lim_msh                     ! ice mesh initialization 
     304      ! 
     305      CALL lim_itd_me_init             ! ice thickness distribution initialization for mecanical deformation 
     306      !                                ! Initial sea-ice state 
     307      IF( .NOT. ln_rstart ) THEN              ! start from rest: sea-ice deduced from sst 
     308         numit = 0 
     309         numit = nit000 - 1 
     310         CALL lim_istate 
     311      ELSE                                    ! start from a restart file 
     312         CALL lim_rst_read 
     313         numit = nit000 - 1 
     314      ENDIF 
     315      CALL lim_var_agg(1) 
     316      CALL lim_var_glo2eqv 
     317      ! 
     318      CALL lim_sbc_init                 ! ice surface boundary condition    
     319      ! 
     320      fr_i(:,:)     = at_i(:,:)         ! initialisation of sea-ice fraction 
     321      tn_ice(:,:,:) = t_su(:,:,:)       ! initialisation of surface temp for coupled simu 
     322      ! 
     323      nstart = numit  + nn_fsbc       
     324      nitrun = nitend - nit000 + 1  
     325      nlast  = numit  + nitrun  
     326      ! 
     327      IF( nstock == 0 )   nstock = nlast + 1 
     328      ! 
     329   END SUBROUTINE sbc_lim_init 
     330 
     331 
     332   SUBROUTINE ice_run 
     333      !!------------------------------------------------------------------- 
     334      !!                  ***  ROUTINE ice_run *** 
     335      !!                  
     336      !! ** Purpose :   Definition some run parameter for ice model 
     337      !! 
     338      !! ** Method  :   Read the namicerun namelist and check the parameter  
     339      !!              values called at the first timestep (nit000) 
     340      !! 
     341      !! ** input   :   Namelist namicerun 
     342      !!------------------------------------------------------------------- 
     343      INTEGER  ::   ios                 ! Local integer output status for namelist read 
     344      NAMELIST/namicerun/ jpl, nlay_i, nlay_s, cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir,  & 
     345         &                ln_limdyn, rn_amax, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
     346      !!------------------------------------------------------------------- 
     347      !                     
     348      REWIND( numnam_ice_ref )              ! Namelist namicerun in reference namelist : Parameters for ice 
     349      READ  ( numnam_ice_ref, namicerun, IOSTAT = ios, ERR = 901) 
     350901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicerun in reference namelist', lwp ) 
     351 
     352      REWIND( numnam_ice_cfg )              ! Namelist namicerun in configuration namelist : Parameters for ice 
     353      READ  ( numnam_ice_cfg, namicerun, IOSTAT = ios, ERR = 902 ) 
     354902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicerun in configuration namelist', lwp ) 
     355      IF(lwm) WRITE ( numoni, namicerun ) 
     356      ! 
     357      ! 
     358      IF(lwp) THEN                        ! control print 
     359         WRITE(numout,*) 
     360         WRITE(numout,*) 'ice_run : ice share parameters for dynamics/advection/thermo of sea-ice' 
     361         WRITE(numout,*) ' ~~~~~~' 
     362         WRITE(numout,*) '   number of ice  categories                               = ', jpl 
     363         WRITE(numout,*) '   number of ice  layers                                   = ', nlay_i 
     364         WRITE(numout,*) '   number of snow layers                                   = ', nlay_s 
     365         WRITE(numout,*) '   switch for ice dynamics (1) or not (0)      ln_limdyn   = ', ln_limdyn 
     366         WRITE(numout,*) '   maximum ice concentration                               = ', rn_amax  
     367         WRITE(numout,*) '   Diagnose heat/salt budget or not          ln_limdiahsb  = ', ln_limdiahsb 
     368         WRITE(numout,*) '   Output   heat/salt budget or not          ln_limdiaout  = ', ln_limdiaout 
     369         WRITE(numout,*) '   control prints in ocean.out for (i,j)=(iiceprt,jiceprt) = ', ln_icectl 
     370         WRITE(numout,*) '   i-index for control prints (ln_icectl=true)             = ', iiceprt 
     371         WRITE(numout,*) '   j-index for control prints (ln_icectl=true)             = ', jiceprt 
     372      ENDIF 
     373      ! 
     374      ! sea-ice timestep and inverse 
     375      rdt_ice   = nn_fsbc * rdttra(1)   
     376      r1_rdtice = 1._wp / rdt_ice  
     377 
     378      ! inverse of nlay_i and nlay_s 
     379      r1_nlay_i = 1._wp / REAL( nlay_i, wp ) 
     380      r1_nlay_s = 1._wp / REAL( nlay_s, wp ) 
     381      ! 
     382#if defined key_bdy 
     383      IF( lwp .AND. ln_limdiahsb )  CALL ctl_warn('online conservation check activated but it does not work with BDY') 
     384#endif 
     385      ! 
     386   END SUBROUTINE ice_run 
     387 
     388 
     389   SUBROUTINE lim_itd_init 
     390      !!------------------------------------------------------------------ 
     391      !!                ***  ROUTINE lim_itd_init *** 
     392      !! 
     393      !! ** Purpose :   Initializes the ice thickness distribution 
     394      !! ** Method  :   ... 
     395      !! ** input   :   Namelist namiceitd 
     396      !!------------------------------------------------------------------- 
     397      INTEGER  ::   ios                 ! Local integer output status for namelist read 
     398      NAMELIST/namiceitd/ nn_catbnd, rn_himean 
     399      ! 
     400      INTEGER  ::   jl                   ! dummy loop index 
     401      REAL(wp) ::   zc1, zc2, zc3, zx1   ! local scalars 
     402      REAL(wp) ::   zhmax, znum, zden, zalpha ! 
     403      !!------------------------------------------------------------------ 
     404      ! 
     405      REWIND( numnam_ice_ref )              ! Namelist namiceitd in reference namelist : Parameters for ice 
     406      READ  ( numnam_ice_ref, namiceitd, IOSTAT = ios, ERR = 903) 
     407903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceitd in reference namelist', lwp ) 
     408 
     409      REWIND( numnam_ice_cfg )              ! Namelist namiceitd in configuration namelist : Parameters for ice 
     410      READ  ( numnam_ice_cfg, namiceitd, IOSTAT = ios, ERR = 904 ) 
     411904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceitd in configuration namelist', lwp ) 
     412      IF(lwm) WRITE ( numoni, namiceitd ) 
     413      ! 
     414      ! 
     415      IF(lwp) THEN                        ! control print 
     416         WRITE(numout,*) 
     417         WRITE(numout,*) 'ice_itd : ice cat distribution' 
     418         WRITE(numout,*) ' ~~~~~~' 
     419         WRITE(numout,*) '   shape of ice categories distribution                          nn_catbnd = ', nn_catbnd 
     420         WRITE(numout,*) '   mean ice thickness in the domain (only active if nn_catbnd=2) rn_himean = ', rn_himean 
     421      ENDIF 
     422 
     423      !---------------------------------- 
     424      !- Thickness categories boundaries  
     425      !---------------------------------- 
     426      IF(lwp) WRITE(numout,*) 
     427      IF(lwp) WRITE(numout,*) 'lim_itd_init : Initialization of ice cat distribution ' 
     428      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
     429 
     430      hi_max(:) = 0._wp 
     431 
     432      SELECT CASE ( nn_catbnd  )        
     433                                   !---------------------- 
     434         CASE (1)                  ! tanh function (CICE) 
     435                                   !---------------------- 
     436         zc1 =  3._wp / REAL( jpl, wp ) 
     437         zc2 = 10._wp * zc1 
     438         zc3 =  3._wp 
     439 
     440         DO jl = 1, jpl 
     441            zx1 = REAL( jl-1, wp ) / REAL( jpl, wp ) 
     442            hi_max(jl) = hi_max(jl-1) + zc1 + zc2 * (1._wp + TANH( zc3 * (zx1 - 1._wp ) ) ) 
     443         END DO 
     444 
     445                                   !---------------------- 
     446         CASE (2)                  ! h^(-alpha) function 
     447                                   !---------------------- 
     448         zalpha = 0.05             ! exponent of the transform function 
     449 
     450         zhmax  = 3.*rn_himean 
     451 
     452         DO jl = 1, jpl  
     453            znum = jpl * ( zhmax+1 )**zalpha 
     454            zden = ( jpl - jl ) * ( zhmax+1 )**zalpha + jl 
     455            hi_max(jl) = ( znum / zden )**(1./zalpha) - 1 
     456         END DO 
     457 
     458      END SELECT 
     459 
     460      DO jl = 1, jpl 
     461         hi_mean(jl) = ( hi_max(jl) + hi_max(jl-1) ) * 0.5_wp 
     462      END DO 
     463 
     464      ! Set hi_max(jpl) to a big value to ensure that all ice is thinner than hi_max(jpl) 
     465      hi_max(jpl) = 99._wp 
     466 
     467      IF(lwp) WRITE(numout,*) ' Thickness category boundaries ' 
     468      IF(lwp) WRITE(numout,*) ' hi_max ', hi_max(0:jpl) 
     469      ! 
     470   END SUBROUTINE lim_itd_init 
     471 
    352472    
    353       SUBROUTINE ice_lim_flx( ptn_ice, palb_ice, pqns_ice, pqsr_ice,   & 
    354          &                          pdqn_ice, pqla_ice, pdql_ice, k_limflx ) 
     473   SUBROUTINE ice_lim_flx( ptn_ice, palb_ice, pqns_ice, pqsr_ice, pdqn_ice, pevap_ice, pdevap_ice, k_limflx ) 
    355474      !!--------------------------------------------------------------------- 
    356       !!                  ***  ROUTINE sbc_ice_lim  *** 
     475      !!                  ***  ROUTINE ice_lim_flx  *** 
    357476      !!                    
    358477      !! ** Purpose :   update the ice surface boundary condition by averaging and / or 
     
    370489      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pqsr_ice   ! net solar flux 
    371490      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdqn_ice   ! non solar flux sensitivity 
    372       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pqla_ice   ! latent heat flux 
    373       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdql_ice   ! latent heat flux sensitivity 
     491      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pevap_ice  ! sublimation 
     492      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdevap_ice ! sublimation sensitivity 
    374493      ! 
    375494      INTEGER  ::   jl      ! dummy loop index 
     
    380499      REAL(wp), POINTER, DIMENSION(:,:) :: z_qsr_m   ! Mean solar heat flux over all categories 
    381500      REAL(wp), POINTER, DIMENSION(:,:) :: z_qns_m   ! Mean non solar heat flux over all categories 
    382       REAL(wp), POINTER, DIMENSION(:,:) :: z_qla_m   ! Mean latent heat flux over all categories 
     501      REAL(wp), POINTER, DIMENSION(:,:) :: z_evap_m  ! Mean sublimation over all categories 
    383502      REAL(wp), POINTER, DIMENSION(:,:) :: z_dqn_m   ! Mean d(qns)/dT over all categories 
    384       REAL(wp), POINTER, DIMENSION(:,:) :: z_dql_m   ! Mean d(qla)/dT over all categories 
     503      REAL(wp), POINTER, DIMENSION(:,:) :: z_devap_m ! Mean d(evap)/dT over all categories 
    385504      !!---------------------------------------------------------------------- 
    386505 
     
    390509      SELECT CASE( k_limflx )                              !==  averaged on all ice categories  ==! 
    391510      CASE( 0 , 1 ) 
    392          CALL wrk_alloc( jpi,jpj, z_qsr_m, z_qns_m, z_qla_m, z_dqn_m, z_dql_m) 
    393          ! 
    394          z_qns_m(:,:) = fice_ice_ave ( pqns_ice (:,:,:) ) 
    395          z_qsr_m(:,:) = fice_ice_ave ( pqsr_ice (:,:,:) ) 
    396          z_dqn_m(:,:) = fice_ice_ave ( pdqn_ice (:,:,:) ) 
    397          z_qla_m(:,:) = fice_ice_ave ( pqla_ice (:,:,:) ) 
    398          z_dql_m(:,:) = fice_ice_ave ( pdql_ice (:,:,:) ) 
     511         CALL wrk_alloc( jpi,jpj, z_qsr_m, z_qns_m, z_evap_m, z_dqn_m, z_devap_m) 
     512         ! 
     513         z_qns_m  (:,:) = fice_ice_ave ( pqns_ice (:,:,:) ) 
     514         z_qsr_m  (:,:) = fice_ice_ave ( pqsr_ice (:,:,:) ) 
     515         z_dqn_m  (:,:) = fice_ice_ave ( pdqn_ice (:,:,:) ) 
     516         z_evap_m (:,:) = fice_ice_ave ( pevap_ice (:,:,:) ) 
     517         z_devap_m(:,:) = fice_ice_ave ( pdevap_ice (:,:,:) ) 
    399518         DO jl = 1, jpl 
    400             pdqn_ice(:,:,jl) = z_dqn_m(:,:) 
    401             pdql_ice(:,:,jl) = z_dql_m(:,:) 
     519            pdqn_ice  (:,:,jl) = z_dqn_m(:,:) 
     520            pdevap_ice(:,:,jl) = z_devap_m(:,:) 
    402521         END DO 
    403522         ! 
    404523         DO jl = 1, jpl 
    405             pqns_ice(:,:,jl) = z_qns_m(:,:) 
    406             pqsr_ice(:,:,jl) = z_qsr_m(:,:) 
    407             pqla_ice(:,:,jl) = z_qla_m(:,:) 
     524            pqns_ice (:,:,jl) = z_qns_m(:,:) 
     525            pqsr_ice (:,:,jl) = z_qsr_m(:,:) 
     526            pevap_ice(:,:,jl) = z_evap_m(:,:) 
    408527         END DO 
    409528         ! 
    410          CALL wrk_dealloc( jpi,jpj, z_qsr_m, z_qns_m, z_qla_m, z_dqn_m, z_dql_m) 
     529         CALL wrk_dealloc( jpi,jpj, z_qsr_m, z_qns_m, z_evap_m, z_dqn_m, z_devap_m) 
    411530      END SELECT 
    412531 
     
    418537         ztem_m(:,:) = fice_ice_ave ( ptn_ice  (:,:,:) )  
    419538         DO jl = 1, jpl 
    420             pqns_ice(:,:,jl) = pqns_ice(:,:,jl) + pdqn_ice(:,:,jl) * (ptn_ice(:,:,jl) - ztem_m(:,:)) 
    421             pqla_ice(:,:,jl) = pqla_ice(:,:,jl) + pdql_ice(:,:,jl) * (ptn_ice(:,:,jl) - ztem_m(:,:)) 
    422             pqsr_ice(:,:,jl) = pqsr_ice(:,:,jl) * ( 1._wp - palb_ice(:,:,jl) ) / ( 1._wp - zalb_m(:,:) )  
     539            pqns_ice (:,:,jl) = pqns_ice (:,:,jl) + pdqn_ice  (:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) ) 
     540            pevap_ice(:,:,jl) = pevap_ice(:,:,jl) + pdevap_ice(:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) ) 
     541            pqsr_ice (:,:,jl) = pqsr_ice (:,:,jl) * ( 1._wp - palb_ice(:,:,jl) ) / ( 1._wp - zalb_m(:,:) )  
    423542         END DO 
    424543         ! 
     
    429548      ! 
    430549   END SUBROUTINE ice_lim_flx 
    431     
    432     
    433    SUBROUTINE lim_ctl( kt ) 
    434       !!----------------------------------------------------------------------- 
    435       !!                   ***  ROUTINE lim_ctl ***  
    436       !!                  
    437       !! ** Purpose :   Alerts in case of model crash 
    438       !!------------------------------------------------------------------- 
    439       INTEGER, INTENT(in) ::   kt      ! ocean time step 
    440       INTEGER  ::   ji, jj, jk,  jl   ! dummy loop indices 
    441       INTEGER  ::   inb_altests       ! number of alert tests (max 20) 
    442       INTEGER  ::   ialert_id         ! number of the current alert 
    443       REAL(wp) ::   ztmelts           ! ice layer melting point 
    444       CHARACTER (len=30), DIMENSION(20)      ::   cl_alname   ! name of alert 
    445       INTEGER           , DIMENSION(20)      ::   inb_alp     ! number of alerts positive 
    446       !!------------------------------------------------------------------- 
    447  
    448       inb_altests = 10 
    449       inb_alp(:)  =  0 
    450  
    451       ! Alert if incompatible volume and concentration 
    452       ialert_id = 2 ! reference number of this alert 
    453       cl_alname(ialert_id) = ' Incompat vol and con         '    ! name of the alert 
    454  
    455       DO jl = 1, jpl 
    456          DO jj = 1, jpj 
    457             DO ji = 1, jpi 
    458                IF(  v_i(ji,jj,jl) /= 0._wp   .AND.   a_i(ji,jj,jl) == 0._wp   ) THEN 
    459                   !WRITE(numout,*) ' ALERTE 2 :   Incompatible volume and concentration ' 
    460                   !WRITE(numout,*) ' at_i     ', at_i(ji,jj) 
    461                   !WRITE(numout,*) ' Point - category', ji, jj, jl 
    462                   !WRITE(numout,*) ' a_i *** a_i_b   ', a_i      (ji,jj,jl), a_i_b  (ji,jj,jl) 
    463                   !WRITE(numout,*) ' v_i *** v_i_b   ', v_i      (ji,jj,jl), v_i_b  (ji,jj,jl) 
    464                   !WRITE(numout,*) ' d_a_i_thd/trp   ', d_a_i_thd(ji,jj,jl), d_a_i_trp(ji,jj,jl) 
    465                   !WRITE(numout,*) ' d_v_i_thd/trp   ', d_v_i_thd(ji,jj,jl), d_v_i_trp(ji,jj,jl) 
    466                   inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    467                ENDIF 
    468             END DO 
    469          END DO 
    470       END DO 
    471  
    472       ! Alerte if very thick ice 
    473       ialert_id = 3 ! reference number of this alert 
    474       cl_alname(ialert_id) = ' Very thick ice               ' ! name of the alert 
    475       jl = jpl  
    476       DO jj = 1, jpj 
    477          DO ji = 1, jpi 
    478             IF(   ht_i(ji,jj,jl)  >  50._wp   ) THEN 
    479                !CALL lim_prt_state( kt, ji, jj, 2, ' ALERTE 3 :   Very thick ice ' ) 
    480                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    481             ENDIF 
    482          END DO 
    483       END DO 
    484  
    485       ! Alert if very fast ice 
    486       ialert_id = 4 ! reference number of this alert 
    487       cl_alname(ialert_id) = ' Very fast ice               ' ! name of the alert 
    488       DO jj = 1, jpj 
    489          DO ji = 1, jpi 
    490             IF(   MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 1.5  .AND.  & 
    491                &  at_i(ji,jj) > 0._wp   ) THEN 
    492                !CALL lim_prt_state( kt, ji, jj, 1, ' ALERTE 4 :   Very fast ice ' ) 
    493                !WRITE(numout,*) ' ice strength             : ', strength(ji,jj) 
    494                !WRITE(numout,*) ' oceanic stress utau      : ', utau(ji,jj)  
    495                !WRITE(numout,*) ' oceanic stress vtau      : ', vtau(ji,jj) 
    496                !WRITE(numout,*) ' sea-ice stress utau_ice  : ', utau_ice(ji,jj)  
    497                !WRITE(numout,*) ' sea-ice stress vtau_ice  : ', vtau_ice(ji,jj) 
    498                !WRITE(numout,*) ' oceanic speed u          : ', u_oce(ji,jj) 
    499                !WRITE(numout,*) ' oceanic speed v          : ', v_oce(ji,jj) 
    500                !WRITE(numout,*) ' sst                      : ', sst_m(ji,jj) 
    501                !WRITE(numout,*) ' sss                      : ', sss_m(ji,jj) 
    502                !WRITE(numout,*)  
    503                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    504             ENDIF 
    505          END DO 
    506       END DO 
    507  
    508       ! Alert if there is ice on continents 
    509       ialert_id = 6 ! reference number of this alert 
    510       cl_alname(ialert_id) = ' Ice on continents           ' ! name of the alert 
    511       DO jj = 1, jpj 
    512          DO ji = 1, jpi 
    513             IF(   tms(ji,jj) <= 0._wp   .AND.   at_i(ji,jj) > 0._wp   ) THEN  
    514                !CALL lim_prt_state( kt, ji, jj, 1, ' ALERTE 6 :   Ice on continents ' ) 
    515                !WRITE(numout,*) ' masks s, u, v        : ', tms(ji,jj), tmu(ji,jj), tmv(ji,jj)  
    516                !WRITE(numout,*) ' sst                  : ', sst_m(ji,jj) 
    517                !WRITE(numout,*) ' sss                  : ', sss_m(ji,jj) 
    518                !WRITE(numout,*) ' at_i(ji,jj)          : ', at_i(ji,jj) 
    519                !WRITE(numout,*) ' v_ice(ji,jj)         : ', v_ice(ji,jj) 
    520                !WRITE(numout,*) ' v_ice(ji,jj-1)       : ', v_ice(ji,jj-1) 
    521                !WRITE(numout,*) ' u_ice(ji-1,jj)       : ', u_ice(ji-1,jj) 
    522                !WRITE(numout,*) ' u_ice(ji,jj)         : ', v_ice(ji,jj) 
    523                ! 
    524                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    525             ENDIF 
    526          END DO 
    527       END DO 
    528  
    529 ! 
    530 !     ! Alert if very fresh ice 
    531       ialert_id = 7 ! reference number of this alert 
    532       cl_alname(ialert_id) = ' Very fresh ice               ' ! name of the alert 
    533       DO jl = 1, jpl 
    534          DO jj = 1, jpj 
    535             DO ji = 1, jpi 
    536                IF( sm_i(ji,jj,jl) < 0.1 .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
    537 !                 CALL lim_prt_state(kt,ji,jj,1, ' ALERTE 7 :   Very fresh ice ' ) 
    538 !                 WRITE(numout,*) ' sst                  : ', sst_m(ji,jj) 
    539 !                 WRITE(numout,*) ' sss                  : ', sss_m(ji,jj) 
    540 !                 WRITE(numout,*)  
    541                   inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    542                ENDIF 
    543             END DO 
    544          END DO 
    545       END DO 
    546 ! 
    547  
    548 !     ! Alert if too old ice 
    549       ialert_id = 9 ! reference number of this alert 
    550       cl_alname(ialert_id) = ' Very old   ice               ' ! name of the alert 
    551       DO jl = 1, jpl 
    552          DO jj = 1, jpj 
    553             DO ji = 1, jpi 
    554                IF ( ( ( ABS( o_i(ji,jj,jl) ) > rdt_ice ) .OR. & 
    555                       ( ABS( o_i(ji,jj,jl) ) < 0._wp) ) .AND. & 
    556                              ( a_i(ji,jj,jl) > 0._wp ) ) THEN 
    557                   !CALL lim_prt_state( kt, ji, jj, 1, ' ALERTE 9 :   Wrong ice age ') 
    558                   inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    559                ENDIF 
    560             END DO 
    561          END DO 
    562       END DO 
    563   
    564       ! Alert on salt flux 
    565       ialert_id = 5 ! reference number of this alert 
    566       cl_alname(ialert_id) = ' High salt flux               ' ! name of the alert 
    567       DO jj = 1, jpj 
    568          DO ji = 1, jpi 
    569             IF( ABS( sfx (ji,jj) ) .GT. 1.0e-2 ) THEN  ! = 1 psu/day for 1m ocean depth 
    570                !CALL lim_prt_state( kt, ji, jj, 3, ' ALERTE 5 :   High salt flux ' ) 
    571                !DO jl = 1, jpl 
    572                   !WRITE(numout,*) ' Category no: ', jl 
    573                   !WRITE(numout,*) ' a_i        : ', a_i      (ji,jj,jl) , ' a_i_b      : ', a_i_b  (ji,jj,jl)    
    574                   !WRITE(numout,*) ' d_a_i_trp  : ', d_a_i_trp(ji,jj,jl) , ' d_a_i_thd  : ', d_a_i_thd(ji,jj,jl)  
    575                   !WRITE(numout,*) ' v_i        : ', v_i      (ji,jj,jl) , ' v_i_b      : ', v_i_b  (ji,jj,jl)    
    576                   !WRITE(numout,*) ' d_v_i_trp  : ', d_v_i_trp(ji,jj,jl) , ' d_v_i_thd  : ', d_v_i_thd(ji,jj,jl)  
    577                   !WRITE(numout,*) ' ' 
    578                !END DO 
    579                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    580             ENDIF 
    581          END DO 
    582       END DO 
    583  
    584       ! Alert if qns very big 
    585       ialert_id = 8 ! reference number of this alert 
    586       cl_alname(ialert_id) = ' fnsolar very big             ' ! name of the alert 
    587       DO jj = 1, jpj 
    588          DO ji = 1, jpi 
    589             IF( ABS( qns(ji,jj) ) > 1500._wp .AND. at_i(ji,jj) > 0._wp ) THEN 
    590                ! 
    591                !WRITE(numout,*) ' ALERTE 8 :   Very high non-solar heat flux' 
    592                !WRITE(numout,*) ' ji, jj    : ', ji, jj 
    593                !WRITE(numout,*) ' qns       : ', qns(ji,jj) 
    594                !WRITE(numout,*) ' sst       : ', sst_m(ji,jj) 
    595                !WRITE(numout,*) ' sss       : ', sss_m(ji,jj) 
    596                ! 
    597                !CALL lim_prt_state( kt, ji, jj, 2, '   ') 
    598                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    599                ! 
    600             ENDIF 
    601          END DO 
    602       END DO 
    603       !+++++ 
    604   
    605       ! Alert if very warm ice 
    606       ialert_id = 10 ! reference number of this alert 
    607       cl_alname(ialert_id) = ' Very warm ice                ' ! name of the alert 
    608       inb_alp(ialert_id) = 0 
    609       DO jl = 1, jpl 
    610          DO jk = 1, nlay_i 
    611             DO jj = 1, jpj 
    612                DO ji = 1, jpi 
    613                   ztmelts    =  -tmut * s_i(ji,jj,jk,jl) + rtt 
    614                   IF( t_i(ji,jj,jk,jl) >= ztmelts  .AND.  v_i(ji,jj,jl) > 1.e-10   & 
    615                      &                             .AND.  a_i(ji,jj,jl) > 0._wp   ) THEN 
    616                      !WRITE(numout,*) ' ALERTE 10 :   Very warm ice' 
    617                      !WRITE(numout,*) ' ji, jj, jk, jl : ', ji, jj, jk, jl 
    618                      !WRITE(numout,*) ' t_i : ', t_i(ji,jj,jk,jl) 
    619                      !WRITE(numout,*) ' e_i : ', e_i(ji,jj,jk,jl) 
    620                      !WRITE(numout,*) ' s_i : ', s_i(ji,jj,jk,jl) 
    621                      !WRITE(numout,*) ' ztmelts : ', ztmelts 
    622                      inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    623                   ENDIF 
    624                END DO 
    625             END DO 
    626          END DO 
    627       END DO 
    628  
    629       ! sum of the alerts on all processors 
    630       IF( lk_mpp ) THEN 
    631          DO ialert_id = 1, inb_altests 
    632             CALL mpp_sum(inb_alp(ialert_id)) 
    633          END DO 
    634       ENDIF 
    635  
    636       ! print alerts 
    637       IF( lwp ) THEN 
    638          ialert_id = 1                                 ! reference number of this alert 
    639          cl_alname(ialert_id) = ' NO alerte 1      '   ! name of the alert 
    640          WRITE(numout,*) ' time step ',kt 
    641          WRITE(numout,*) ' All alerts at the end of ice model ' 
    642          DO ialert_id = 1, inb_altests 
    643             WRITE(numout,*) ialert_id, cl_alname(ialert_id)//' : ', inb_alp(ialert_id), ' times ! ' 
    644          END DO 
    645       ENDIF 
    646      ! 
    647    END SUBROUTINE lim_ctl 
    648   
    649     
    650    SUBROUTINE lim_prt_state( kt, ki, kj, kn, cd1 ) 
    651       !!----------------------------------------------------------------------- 
    652       !!                   ***  ROUTINE lim_prt_state ***  
    653       !!                  
    654       !! ** Purpose :   Writes global ice state on the (i,j) point  
    655       !!                in ocean.ouput  
    656       !!                3 possibilities exist  
    657       !!                n = 1/-1 -> simple ice state (plus Mechanical Check if -1) 
    658       !!                n = 2    -> exhaustive state 
    659       !!                n = 3    -> ice/ocean salt fluxes 
    660       !! 
    661       !! ** input   :   point coordinates (i,j)  
    662       !!                n : number of the option 
    663       !!------------------------------------------------------------------- 
    664       INTEGER         , INTENT(in) ::   kt            ! ocean time step 
    665       INTEGER         , INTENT(in) ::   ki, kj, kn    ! ocean gridpoint indices 
    666       CHARACTER(len=*), INTENT(in) ::   cd1           ! 
    667       !! 
    668       INTEGER :: jl, ji, jj 
    669       !!------------------------------------------------------------------- 
    670  
    671       DO ji = mi0(ki), mi1(ki) 
    672          DO jj = mj0(kj), mj1(kj) 
    673  
    674             WRITE(numout,*) ' time step ',kt,' ',cd1             ! print title 
    675  
    676             !---------------- 
    677             !  Simple state 
    678             !---------------- 
    679              
    680             IF ( kn == 1 .OR. kn == -1 ) THEN 
    681                WRITE(numout,*) ' lim_prt_state - Point : ',ji,jj 
    682                WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 
    683                WRITE(numout,*) ' Simple state ' 
    684                WRITE(numout,*) ' masks s,u,v   : ', tms(ji,jj), tmu(ji,jj), tmv(ji,jj) 
    685                WRITE(numout,*) ' lat - long    : ', gphit(ji,jj), glamt(ji,jj) 
    686                WRITE(numout,*) ' Time step     : ', numit 
    687                WRITE(numout,*) ' - Ice drift   ' 
    688                WRITE(numout,*) '   ~~~~~~~~~~~ ' 
    689                WRITE(numout,*) ' u_ice(i-1,j)  : ', u_ice(ji-1,jj) 
    690                WRITE(numout,*) ' u_ice(i  ,j)  : ', u_ice(ji,jj) 
    691                WRITE(numout,*) ' v_ice(i  ,j-1): ', v_ice(ji,jj-1) 
    692                WRITE(numout,*) ' v_ice(i  ,j)  : ', v_ice(ji,jj) 
    693                WRITE(numout,*) ' strength      : ', strength(ji,jj) 
    694                WRITE(numout,*) 
    695                WRITE(numout,*) ' - Cell values ' 
    696                WRITE(numout,*) '   ~~~~~~~~~~~ ' 
    697                WRITE(numout,*) ' cell area     : ', area(ji,jj) 
    698                WRITE(numout,*) ' at_i          : ', at_i(ji,jj)        
    699                WRITE(numout,*) ' vt_i          : ', vt_i(ji,jj)        
    700                WRITE(numout,*) ' vt_s          : ', vt_s(ji,jj)        
    701                DO jl = 1, jpl 
    702                   WRITE(numout,*) ' - Category (', jl,')' 
    703                   WRITE(numout,*) ' a_i           : ', a_i(ji,jj,jl) 
    704                   WRITE(numout,*) ' ht_i          : ', ht_i(ji,jj,jl) 
    705                   WRITE(numout,*) ' ht_s          : ', ht_s(ji,jj,jl) 
    706                   WRITE(numout,*) ' v_i           : ', v_i(ji,jj,jl) 
    707                   WRITE(numout,*) ' v_s           : ', v_s(ji,jj,jl) 
    708                   WRITE(numout,*) ' e_s           : ', e_s(ji,jj,1,jl)/1.0e9 
    709                   WRITE(numout,*) ' e_i           : ', e_i(ji,jj,1:nlay_i,jl)/1.0e9 
    710                   WRITE(numout,*) ' t_su          : ', t_su(ji,jj,jl) 
    711                   WRITE(numout,*) ' t_snow        : ', t_s(ji,jj,1,jl) 
    712                   WRITE(numout,*) ' t_i           : ', t_i(ji,jj,1:nlay_i,jl) 
    713                   WRITE(numout,*) ' sm_i          : ', sm_i(ji,jj,jl) 
    714                   WRITE(numout,*) ' smv_i         : ', smv_i(ji,jj,jl) 
    715                   WRITE(numout,*) 
    716                END DO 
    717             ENDIF 
    718             IF( kn == -1 ) THEN 
    719                WRITE(numout,*) ' Mechanical Check ************** ' 
    720                WRITE(numout,*) ' Check what means ice divergence ' 
    721                WRITE(numout,*) ' Total ice concentration ', at_i (ji,jj) 
    722                WRITE(numout,*) ' Total lead fraction     ', ato_i(ji,jj) 
    723                WRITE(numout,*) ' Sum of both             ', ato_i(ji,jj) + at_i(ji,jj) 
    724                WRITE(numout,*) ' Sum of both minus 1     ', ato_i(ji,jj) + at_i(ji,jj) - 1.00 
    725             ENDIF 
    726              
    727  
    728             !-------------------- 
    729             !  Exhaustive state 
    730             !-------------------- 
    731              
    732             IF ( kn .EQ. 2 ) THEN 
    733                WRITE(numout,*) ' lim_prt_state - Point : ',ji,jj 
    734                WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 
    735                WRITE(numout,*) ' Exhaustive state ' 
    736                WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) 
    737                WRITE(numout,*) ' Time step ', numit 
    738                WRITE(numout,*)  
    739                WRITE(numout,*) ' - Cell values ' 
    740                WRITE(numout,*) '   ~~~~~~~~~~~ ' 
    741                WRITE(numout,*) ' cell area     : ', area(ji,jj) 
    742                WRITE(numout,*) ' at_i          : ', at_i(ji,jj)        
    743                WRITE(numout,*) ' vt_i          : ', vt_i(ji,jj)        
    744                WRITE(numout,*) ' vt_s          : ', vt_s(ji,jj)        
    745                WRITE(numout,*) ' u_ice(i-1,j)  : ', u_ice(ji-1,jj) 
    746                WRITE(numout,*) ' u_ice(i  ,j)  : ', u_ice(ji,jj) 
    747                WRITE(numout,*) ' v_ice(i  ,j-1): ', v_ice(ji,jj-1) 
    748                WRITE(numout,*) ' v_ice(i  ,j)  : ', v_ice(ji,jj) 
    749                WRITE(numout,*) ' strength      : ', strength(ji,jj) 
    750                WRITE(numout,*) ' d_u_ice_dyn   : ', d_u_ice_dyn(ji,jj), ' d_v_ice_dyn   : ', d_v_ice_dyn(ji,jj) 
    751                WRITE(numout,*) ' u_ice_b       : ', u_ice_b(ji,jj)    , ' v_ice_b       : ', v_ice_b(ji,jj)   
    752                WRITE(numout,*) 
    753                 
    754                DO jl = 1, jpl 
    755                   WRITE(numout,*) ' - Category (',jl,')' 
    756                   WRITE(numout,*) '   ~~~~~~~~         '  
    757                   WRITE(numout,*) ' ht_i       : ', ht_i(ji,jj,jl)             , ' ht_s       : ', ht_s(ji,jj,jl) 
    758                   WRITE(numout,*) ' t_i        : ', t_i(ji,jj,1:nlay_i,jl) 
    759                   WRITE(numout,*) ' t_su       : ', t_su(ji,jj,jl)             , ' t_s        : ', t_s(ji,jj,1,jl) 
    760                   WRITE(numout,*) ' sm_i       : ', sm_i(ji,jj,jl)             , ' o_i        : ', o_i(ji,jj,jl) 
    761                   WRITE(numout,*) ' a_i        : ', a_i(ji,jj,jl)              , ' a_i_b      : ', a_i_b(ji,jj,jl)    
    762                   WRITE(numout,*) ' d_a_i_trp  : ', d_a_i_trp(ji,jj,jl)        , ' d_a_i_thd  : ', d_a_i_thd(ji,jj,jl)  
    763                   WRITE(numout,*) ' v_i        : ', v_i(ji,jj,jl)              , ' v_i_b      : ', v_i_b(ji,jj,jl)    
    764                   WRITE(numout,*) ' d_v_i_trp  : ', d_v_i_trp(ji,jj,jl)        , ' d_v_i_thd  : ', d_v_i_thd(ji,jj,jl)  
    765                   WRITE(numout,*) ' v_s        : ', v_s(ji,jj,jl)              , ' v_s_b      : ', v_s_b(ji,jj,jl)   
    766                   WRITE(numout,*) ' d_v_s_trp  : ', d_v_s_trp(ji,jj,jl)        , ' d_v_s_thd  : ', d_v_s_thd(ji,jj,jl) 
    767                   WRITE(numout,*) ' e_i1       : ', e_i(ji,jj,1,jl)/1.0e9      , ' ei1        : ', e_i_b(ji,jj,1,jl)/1.0e9  
    768                   WRITE(numout,*) ' de_i1_trp  : ', d_e_i_trp(ji,jj,1,jl)/1.0e9, ' de_i1_thd  : ', d_e_i_thd(ji,jj,1,jl)/1.0e9 
    769                   WRITE(numout,*) ' e_i2       : ', e_i(ji,jj,2,jl)/1.0e9      , ' ei2_b      : ', e_i_b(ji,jj,2,jl)/1.0e9   
    770                   WRITE(numout,*) ' de_i2_trp  : ', d_e_i_trp(ji,jj,2,jl)/1.0e9, ' de_i2_thd  : ', d_e_i_thd(ji,jj,2,jl)/1.0e9 
    771                   WRITE(numout,*) ' e_snow     : ', e_s(ji,jj,1,jl)            , ' e_snow_b   : ', e_s_b(ji,jj,1,jl)  
    772                   WRITE(numout,*) ' d_e_s_trp  : ', d_e_s_trp(ji,jj,1,jl)      , ' d_e_s_thd  : ', d_e_s_thd(ji,jj,1,jl) 
    773                   WRITE(numout,*) ' smv_i      : ', smv_i(ji,jj,jl)            , ' smv_i_b    : ', smv_i_b(ji,jj,jl)    
    774                   WRITE(numout,*) ' d_smv_i_trp: ', d_smv_i_trp(ji,jj,jl)      , ' d_smv_i_thd: ', d_smv_i_thd(ji,jj,jl)  
    775                   WRITE(numout,*) ' oa_i       : ', oa_i(ji,jj,jl)             , ' oa_i_b     : ', oa_i_b(ji,jj,jl) 
    776                   WRITE(numout,*) ' d_oa_i_trp : ', d_oa_i_trp(ji,jj,jl)       , ' d_oa_i_thd : ', d_oa_i_thd(ji,jj,jl) 
    777                END DO !jl 
    778                 
    779                WRITE(numout,*) 
    780                WRITE(numout,*) ' - Heat / FW fluxes ' 
    781                WRITE(numout,*) '   ~~~~~~~~~~~~~~~~ ' 
    782                WRITE(numout,*) ' - Heat fluxes in and out the ice ***' 
    783                WRITE(numout,*) ' qsr_ini       : ', pfrld(ji,jj) * qsr(ji,jj) + SUM( a_i_b(ji,jj,:) * qsr_ice(ji,jj,:) ) 
    784                WRITE(numout,*) ' qns_ini       : ', pfrld(ji,jj) * qns(ji,jj) + SUM( a_i_b(ji,jj,:) * qns_ice(ji,jj,:) ) 
    785                WRITE(numout,*) 
    786                WRITE(numout,*)  
    787                WRITE(numout,*) ' sst        : ', sst_m(ji,jj)   
    788                WRITE(numout,*) ' sss        : ', sss_m(ji,jj)   
    789                WRITE(numout,*)  
    790                WRITE(numout,*) ' - Stresses ' 
    791                WRITE(numout,*) '   ~~~~~~~~ ' 
    792                WRITE(numout,*) ' utau_ice   : ', utau_ice(ji,jj)  
    793                WRITE(numout,*) ' vtau_ice   : ', vtau_ice(ji,jj) 
    794                WRITE(numout,*) ' utau       : ', utau    (ji,jj)  
    795                WRITE(numout,*) ' vtau       : ', vtau    (ji,jj) 
    796                WRITE(numout,*) ' oc. vel. u : ', u_oce   (ji,jj) 
    797                WRITE(numout,*) ' oc. vel. v : ', v_oce   (ji,jj) 
    798             ENDIF 
    799              
    800             !--------------------- 
    801             ! Salt / heat fluxes 
    802             !--------------------- 
    803              
    804             IF ( kn .EQ. 3 ) THEN 
    805                WRITE(numout,*) ' lim_prt_state - Point : ',ji,jj 
    806                WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 
    807                WRITE(numout,*) ' - Salt / Heat Fluxes ' 
    808                WRITE(numout,*) '   ~~~~~~~~~~~~~~~~ ' 
    809                WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) 
    810                WRITE(numout,*) ' Time step ', numit 
    811                WRITE(numout,*) 
    812                WRITE(numout,*) ' - Heat fluxes at bottom interface ***' 
    813                WRITE(numout,*) ' qsr       : ', qsr(ji,jj) 
    814                WRITE(numout,*) ' qns       : ', qns(ji,jj) 
    815                WRITE(numout,*) 
    816                WRITE(numout,*) ' hfx_mass     : ', hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_snw(ji,jj) + hfx_res(ji,jj) 
    817                WRITE(numout,*) ' hfx_in       : ', hfx_in(ji,jj) 
    818                WRITE(numout,*) ' hfx_out      : ', hfx_out(ji,jj) 
    819                WRITE(numout,*) ' dhc          : ', diag_heat_dhc(ji,jj)               
    820                WRITE(numout,*) 
    821                WRITE(numout,*) ' hfx_dyn      : ', hfx_dyn(ji,jj) 
    822                WRITE(numout,*) ' hfx_thd      : ', hfx_thd(ji,jj) 
    823                WRITE(numout,*) ' hfx_res      : ', hfx_res(ji,jj) 
    824                WRITE(numout,*) ' fhtur        : ', fhtur(ji,jj)  
    825                WRITE(numout,*) ' qlead        : ', qlead(ji,jj) * r1_rdtice 
    826                WRITE(numout,*) 
    827                WRITE(numout,*) ' - Salt fluxes at bottom interface ***' 
    828                WRITE(numout,*) ' emp       : ', emp    (ji,jj) 
    829                WRITE(numout,*) ' sfx       : ', sfx    (ji,jj) 
    830                WRITE(numout,*) ' sfx_res   : ', sfx_res(ji,jj) 
    831                WRITE(numout,*) ' sfx_bri   : ', sfx_bri(ji,jj) 
    832                WRITE(numout,*) ' sfx_dyn   : ', sfx_dyn(ji,jj) 
    833                WRITE(numout,*) 
    834                WRITE(numout,*) ' - Momentum fluxes ' 
    835                WRITE(numout,*) ' utau      : ', utau(ji,jj)  
    836                WRITE(numout,*) ' vtau      : ', vtau(ji,jj) 
    837             ENDIF  
    838             WRITE(numout,*) ' ' 
    839             ! 
    840          END DO 
    841       END DO 
    842       ! 
    843    END SUBROUTINE lim_prt_state 
    844     
     550 
     551   SUBROUTINE sbc_lim_bef 
     552      !!---------------------------------------------------------------------- 
     553      !!                  ***  ROUTINE sbc_lim_bef  *** 
     554      !! 
     555      !! ** purpose :  store ice variables at "before" time step  
     556      !!---------------------------------------------------------------------- 
     557      a_i_b  (:,:,:)   = a_i  (:,:,:)     ! ice area 
     558      e_i_b  (:,:,:,:) = e_i  (:,:,:,:)   ! ice thermal energy 
     559      v_i_b  (:,:,:)   = v_i  (:,:,:)     ! ice volume 
     560      v_s_b  (:,:,:)   = v_s  (:,:,:)     ! snow volume  
     561      e_s_b  (:,:,:,:) = e_s  (:,:,:,:)   ! snow thermal energy 
     562      smv_i_b(:,:,:)   = smv_i(:,:,:)     ! salt content 
     563      oa_i_b (:,:,:)   = oa_i (:,:,:)     ! areal age content 
     564      u_ice_b(:,:)     = u_ice(:,:) 
     565      v_ice_b(:,:)     = v_ice(:,:) 
     566       
     567   END SUBROUTINE sbc_lim_bef 
     568 
     569   SUBROUTINE sbc_lim_diag0 
     570      !!---------------------------------------------------------------------- 
     571      !!                  ***  ROUTINE sbc_lim_diag0  *** 
     572      !! 
     573      !! ** purpose :  set ice-ocean and ice-atm. fluxes to zeros at the beggining 
     574      !!               of the time step 
     575      !!---------------------------------------------------------------------- 
     576      sfx    (:,:) = 0._wp   ; 
     577      sfx_bri(:,:) = 0._wp   ;  
     578      sfx_sni(:,:) = 0._wp   ;   sfx_opw(:,:) = 0._wp 
     579      sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
     580      sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
     581      sfx_res(:,:) = 0._wp 
     582       
     583      wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
     584      wfx_sni(:,:) = 0._wp   ;   wfx_opw(:,:) = 0._wp 
     585      wfx_bog(:,:) = 0._wp   ;   wfx_dyn(:,:) = 0._wp 
     586      wfx_bom(:,:) = 0._wp   ;   wfx_sum(:,:) = 0._wp 
     587      wfx_res(:,:) = 0._wp   ;   wfx_sub(:,:) = 0._wp 
     588      wfx_spr(:,:) = 0._wp   ;    
     589       
     590      hfx_thd(:,:) = 0._wp   ;    
     591      hfx_snw(:,:) = 0._wp   ;   hfx_opw(:,:) = 0._wp 
     592      hfx_bog(:,:) = 0._wp   ;   hfx_dyn(:,:) = 0._wp 
     593      hfx_bom(:,:) = 0._wp   ;   hfx_sum(:,:) = 0._wp 
     594      hfx_res(:,:) = 0._wp   ;   hfx_sub(:,:) = 0._wp 
     595      hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
     596      hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
     597      hfx_err_dif(:,:) = 0._wp   ; 
     598 
     599      afx_tot(:,:) = 0._wp   ; 
     600      afx_dyn(:,:) = 0._wp   ;   afx_thd(:,:) = 0._wp 
     601 
     602      diag_heat(:,:) = 0._wp ;   diag_smvi(:,:) = 0._wp ; 
     603      diag_vice(:,:) = 0._wp ;   diag_vsnw(:,:) = 0._wp ; 
     604       
     605   END SUBROUTINE sbc_lim_diag0 
     606 
    845607      
    846608   FUNCTION fice_cell_ave ( ptab ) 
     
    853615       
    854616      fice_cell_ave (:,:) = 0.0_wp 
    855        
    856617      DO jl = 1, jpl 
    857          fice_cell_ave (:,:) = fice_cell_ave (:,:) & 
    858             &                  + a_i (:,:,jl) * ptab (:,:,jl) 
     618         fice_cell_ave (:,:) = fice_cell_ave (:,:) + a_i (:,:,jl) * ptab (:,:,jl) 
    859619      END DO 
    860620       
     
    870630 
    871631      fice_ice_ave (:,:) = 0.0_wp 
    872       WHERE ( at_i (:,:) .GT. 0.0_wp ) fice_ice_ave (:,:) = fice_cell_ave ( ptab (:,:,:)) / at_i (:,:) 
     632      WHERE ( at_i (:,:) > 0.0_wp ) fice_ice_ave (:,:) = fice_cell_ave ( ptab (:,:,:)) / at_i (:,:) 
    873633 
    874634   END FUNCTION fice_ice_ave 
     
    883643      WRITE(*,*) 'sbc_ice_lim: You should not have seen this print! error?', kt, kblk 
    884644   END SUBROUTINE sbc_ice_lim 
     645   SUBROUTINE sbc_lim_init                 ! Dummy routine 
     646   END SUBROUTINE sbc_lim_init 
    885647#endif 
    886648 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90

    r5038 r5620  
    101101      REAL(wp), DIMENSION(:,:,:), POINTER :: zalb_ice  ! mean ice albedo 
    102102      REAL(wp), DIMENSION(:,:,:), POINTER :: zsist     ! ice surface temperature (K) 
     103      REAL(wp), DIMENSION(:,:  ), POINTER :: zutau_ice, zvtau_ice  
    103104      !!---------------------------------------------------------------------- 
    104  
    105       CALL wrk_alloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 
    106105 
    107106      IF( kt == nit000 ) THEN 
     
    124123         &*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) + 1 
    125124# endif 
     125 
     126         CALL wrk_alloc( jpi,jpj  , zutau_ice, zvtau_ice) 
     127         CALL wrk_alloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 
     128 
    126129         !  Bulk Formulea ! 
    127130         !----------------! 
     
    132135               DO ji = 2, jpi   ! NO vector opt. possible 
    133136                  u_oce(ji,jj) = 0.5_wp * ( ssu_m(ji-1,jj  ) * umask(ji-1,jj  ,1) & 
    134                      &           + ssu_m(ji-1,jj-1) * umask(ji-1,jj-1,1) ) * tmu(ji,jj) 
     137                     &                    + ssu_m(ji-1,jj-1) * umask(ji-1,jj-1,1) ) * tmu(ji,jj) 
    135138                  v_oce(ji,jj) = 0.5_wp * ( ssv_m(ji  ,jj-1) * vmask(ji  ,jj-1,1) & 
    136                      &           + ssv_m(ji-1,jj-1) * vmask(ji-1,jj-1,1) ) * tmu(ji,jj) 
     139                     &                    + ssv_m(ji-1,jj-1) * vmask(ji-1,jj-1,1) ) * tmu(ji,jj) 
    137140               END DO 
    138141            END DO 
     
    147150 
    148151         ! ... masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
    149          tfu(:,:) = eos_fzp( sss_m ) +  rt0  
     152         CALL eos_fzp( sss_m(:,:), tfu(:,:) ) 
     153         tfu(:,:) = tfu(:,:) + rt0 
    150154 
    151155         zsist (:,:,1) = sist (:,:) + rt0 * ( 1. - tmask(:,:,1) ) 
     
    158162 
    159163         SELECT CASE( ksbc ) 
    160          CASE( jp_core , jp_cpl )   ! CORE and COUPLED bulk formulations 
     164         CASE( jp_core , jp_purecpl )   ! CORE and COUPLED bulk formulations 
    161165 
    162166            ! albedo depends on cloud fraction because of non-linear spectral effects 
     
    182186         SELECT CASE( ksbc ) 
    183187         CASE( jp_clio )           ! CLIO bulk formulation 
    184             CALL blk_ice_clio( zsist, zalb_cs    , zalb_os    , zalb_ice   ,            & 
    185                &                      utau_ice   , vtau_ice   , qns_ice    , qsr_ice,   & 
    186                &                      qla_ice    , dqns_ice   , dqla_ice   ,            & 
    187                &                      tprecip    , sprecip    ,                         & 
    188                &                      fr1_i0     , fr2_i0     , cp_ice_msh , jpl  ) 
     188!           CALL blk_ice_clio( zsist, zalb_cs    , zalb_os    , zalb_ice   ,            & 
     189!              &                      utau_ice   , vtau_ice   , qns_ice    , qsr_ice,   & 
     190!              &                      qla_ice    , dqns_ice   , dqla_ice   ,            & 
     191!              &                      tprecip    , sprecip    ,                         & 
     192!              &                      fr1_i0     , fr2_i0     , cp_ice_msh , jpl  ) 
     193            CALL blk_ice_clio_tau 
     194            CALL blk_ice_clio_flx( zsist, zalb_cs, zalb_os, zalb_ice ) 
    189195 
    190196         CASE( jp_core )           ! CORE bulk formulation 
    191             CALL blk_ice_core( zsist, u_ice      , v_ice      , zalb_ice   ,            & 
    192                &                      utau_ice   , vtau_ice   , qns_ice    , qsr_ice,   & 
    193                &                      qla_ice    , dqns_ice   , dqla_ice   ,            & 
    194                &                      tprecip    , sprecip    ,                         & 
    195                &                      fr1_i0     , fr2_i0     , cp_ice_msh , jpl  ) 
    196             IF( ltrcdm2dc_ice )   CALL blk_ice_meanqsr( zalb_ice, qsr_ice_mean, jpl ) 
    197  
    198          CASE( jp_cpl )            ! Coupled formulation : atmosphere-ice stress only (fluxes provided after ice dynamics) 
     197            CALL blk_ice_core_tau 
     198            CALL blk_ice_core_flx( zsist, zalb_ice ) 
     199 
     200         CASE( jp_purecpl )            ! Coupled formulation : atmosphere-ice stress only (fluxes provided after ice dynamics) 
    199201            CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) 
    200202         END SELECT 
     203          
     204         IF( ln_mixcpl) THEN 
     205            CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) 
     206            utau_ice(:,:) = utau_ice(:,:) * xcplmask(:,:,0) + zutau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 
     207            vtau_ice(:,:) = vtau_ice(:,:) * xcplmask(:,:,0) + zvtau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 
     208         ENDIF 
    201209 
    202210         CALL iom_put( 'utau_ice', utau_ice )     ! Wind stress over ice along i-axis at I-point 
     
    228236         END IF 
    229237         !                                             ! Ice surface fluxes in coupled mode  
    230          IF( ksbc == jp_cpl )   THEN 
     238         IF( ln_cpl ) THEN   ! pure coupled and mixed forced-coupled configurations 
    231239            a_i(:,:,1)=fr_i 
    232240            CALL sbc_cpl_ice_flx( frld,                                              & 
    233241            !                                optional arguments, used only in 'mixed oce-ice' case 
    234             &                                             palbi = zalb_ice, psst = sst_m, pist = zsist ) 
     242            &                                             palbi=zalb_ice, psst=sst_m, pist=zsist ) 
    235243            sprecip(:,:) = - emp_ice(:,:)   ! Ugly patch, WARNING, in coupled mode, sublimation included in snow (parsub = 0.) 
    236244         ENDIF 
    237245                           CALL lim_thd_2      ( kt )      ! Ice thermodynamics  
    238246                           CALL lim_sbc_flx_2  ( kt )      ! update surface ocean mass, heat & salt fluxes  
    239 #if defined key_top 
    240         IF( ltrcdm2dc_ice )CALL lim_bio_meanqsr_2 
    241 #endif 
    242247 
    243248         IF(  .NOT. lk_mpp )THEN 
     
    253258         IF( .NOT. Agrif_Root() )   CALL agrif_update_lim2( kt ) 
    254259# endif 
     260         ! 
     261         CALL wrk_dealloc( jpi,jpj  , zutau_ice, zvtau_ice) 
     262         CALL wrk_dealloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 
    255263         ! 
    256264      ENDIF                                    ! End sea-ice time step only 
     
    264272      IF( ln_limdyn    )   CALL lim_sbc_tau_2( kt, ub(:,:,1), vb(:,:,1) )  ! using before instantaneous surf. currents 
    265273      ! 
    266       CALL wrk_dealloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 
    267       ! 
    268274   END SUBROUTINE sbc_ice_lim_2 
    269275 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    77   !! History :  3.2   !  2011-02  (C.Harris  ) Original code isf cav 
    88   !!            X.X   !  2006-02  (C. Wang   ) Original code bg03 
    9    !!            3.4   !  2013-03  (P. Mathiot) Merging 
     9   !!            3.4   !  2013-03  (P. Mathiot) Merging + parametrization 
    1010   !!---------------------------------------------------------------------- 
    1111 
     
    3737 
    3838   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   risf_tsc_b, risf_tsc    
    39    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fwfisf_b, fwfisf  !: evaporation damping   [kg/m2/s] 
    40    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qisf            !: net heat flux from ice shelf 
     39   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qisf              !: net heat flux from ice shelf 
    4140   REAL(wp), PUBLIC ::   rn_hisf_tbl                 !: thickness of top boundary layer [m] 
    4241   LOGICAL , PUBLIC ::   ln_divisf                   !: flag to correct divergence  
     
    8180   !!---------------------------------------------------------------------- 
    8281   !! NEMO/OPA 3.0 , LOCEAN-IPSL (2008) 
    83    !! $Id: sbcice_if.F90 1730 2009-11-16 14:34:19Z smasson $ 
     82   !! $Id$ 
    8483   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    8584   !!---------------------------------------------------------------------- 
     
    309308      sbc_isf_alloc = 0       ! set to zero if no array to be allocated 
    310309      IF( .NOT. ALLOCATED( qisf ) ) THEN 
    311          ALLOCATE(  risf_tsc(jpi,jpj,jpts), risf_tsc_b(jpi,jpj,jpts)              , & 
    312                &    qisf(jpi,jpj)     , fwfisf(jpi,jpj)     , fwfisf_b(jpi,jpj)   , & 
    313                &    rhisf_tbl(jpi,jpj), r1_hisf_tbl(jpi,jpj), rzisf_tbl(jpi,jpj)  , & 
    314                &    ttbl(jpi,jpj)     , stbl(jpi,jpj)       , utbl(jpi,jpj)       , & 
    315                &    vtbl(jpi, jpj)    , risfLeff(jpi,jpj)   , rhisf_tbl_0(jpi,jpj), & 
    316                &    ralpha(jpi,jpj)   , misfkt(jpi,jpj)     , misfkb(jpi,jpj)     , & 
     310         ALLOCATE(  risf_tsc(jpi,jpj,jpts), risf_tsc_b(jpi,jpj,jpts), qisf(jpi,jpj)   , & 
     311               &    rhisf_tbl(jpi,jpj)    , r1_hisf_tbl(jpi,jpj), rzisf_tbl(jpi,jpj)  , & 
     312               &    ttbl(jpi,jpj)         , stbl(jpi,jpj)       , utbl(jpi,jpj)       , & 
     313               &    vtbl(jpi, jpj)        , risfLeff(jpi,jpj)   , rhisf_tbl_0(jpi,jpj), & 
     314               &    ralpha(jpi,jpj)       , misfkt(jpi,jpj)     , misfkb(jpi,jpj)     , & 
    317315               &    STAT= sbc_isf_alloc ) 
    318316         ! 
     
    372370             ! Calculate freezing temperature 
    373371                zpress = grav*rau0*fsdept(ji,jj,ik)*1.e-04  
    374                 zt_frz = eos_fzp(tsb(ji,jj,ik,jp_sal), zpress)  
     372                CALL eos_fzp(tsb(ji,jj,ik,jp_sal), zt_frz, zpress)  
    375373                zt_sum = zt_sum + (tsn(ji,jj,ik,jp_tem)-zt_frz) * fse3t(ji,jj,ik) * tmask(ji,jj,ik)  ! sum temp 
    376374             ENDDO 
     
    454452      zti(:,:)=tinsitu( ttbl, stbl, zpress ) 
    455453! Calculate freezing temperature 
    456       zfrz(:,:)=eos_fzp( sss_m(:,:), zpress ) 
     454      CALL eos_fzp( sss_m(:,:), zfrz(:,:), zpress ) 
    457455 
    458456       
     
    563561      CALL iom_put('isfgammat', zgammat2d) 
    564562      CALL iom_put('isfgammas', zgammas2d) 
    565          ! 
    566       !CALL wrk_dealloc( jpi,jpj, zfrz,zpress,zti, zqisf, zfwfisf  ) 
     563      ! 
    567564      CALL wrk_dealloc( jpi,jpj, zfrz,zpress,zti, zgammat2d, zgammas2d ) 
    568565      ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r5038 r5620  
    1313   !!            3.4  ! 2011-11  (C. Harris) CICE added as an option 
    1414   !!            3.5  ! 2012-11  (A. Coward, G. Madec) Rethink of heat, mass and salt surface fluxes 
     15   !!            3.6  ! 2014-11  (P. Mathiot, C. Harris) add ice shelves melting                     
    1516   !!---------------------------------------------------------------------- 
    1617 
     
    2324   USE phycst           ! physical constants 
    2425   USE sbc_oce          ! Surface boundary condition: ocean fields 
     26   USE trc_oce          ! shared ocean-passive tracers variables 
    2527   USE sbc_ice          ! Surface boundary condition: ice fields 
    2628   USE sbcdcy           ! surface boundary condition: diurnal cycle 
     
    3739   USE sbcice_cice      ! surface boundary condition: CICE    sea-ice model 
    3840   USE sbccpl           ! surface boundary condition: coupled florulation 
     41   USE cpl_oasis3       ! OASIS routines for coupling 
    3942   USE sbcssr           ! surface boundary condition: sea surface restoring 
    4043   USE sbcrnf           ! surface boundary condition: runoffs 
     
    5053   USE timing           ! Timing 
    5154   USE sbcwave          ! Wave module 
     55   USE bdy_par          ! Require lk_bdy 
    5256 
    5357   IMPLICIT NONE 
     
    8286      INTEGER ::   icpt   ! local integer 
    8387      !! 
    84       NAMELIST/namsbc/ nn_fsbc   , ln_ana    , ln_flx,  ln_blk_clio, ln_blk_core,           & 
    85          &             ln_blk_mfs, ln_apr_dyn, nn_ice,  nn_ice_embd, ln_dm2dc   , ln_rnf,   & 
    86          &             ln_ssr    ,  nn_isf , nn_fwb    , ln_cdgw , ln_wave , ln_sdw, nn_lsm, nn_limflx 
     88      NAMELIST/namsbc/ nn_fsbc   , ln_ana    , ln_flx, ln_blk_clio, ln_blk_core, ln_mixcpl,   & 
     89         &             ln_blk_mfs, ln_apr_dyn, nn_ice, nn_ice_embd, ln_dm2dc   , ln_rnf   ,   & 
     90         &             ln_ssr    , nn_isf    , nn_fwb, ln_cdgw    , ln_wave    , ln_sdw   ,   & 
     91         &             nn_lsm    , nn_limflx , nn_components, ln_cpl 
    8792      INTEGER  ::   ios 
     93      INTEGER  ::   ierr, ierr0, ierr1, ierr2, ierr3, jpm 
     94      LOGICAL  ::   ll_purecpl 
    8895      !!---------------------------------------------------------------------- 
    8996 
     
    113120          nn_ice      =   0 
    114121      ENDIF 
    115       
     122 
    116123      IF(lwp) THEN               ! Control print 
    117124         WRITE(numout,*) '        Namelist namsbc (partly overwritten with CPP key setting)' 
     
    123130         WRITE(numout,*) '              CORE bulk  formulation                     ln_blk_core = ', ln_blk_core 
    124131         WRITE(numout,*) '              MFS  bulk  formulation                     ln_blk_mfs  = ', ln_blk_mfs 
    125          WRITE(numout,*) '              coupled    formulation (T if key_oasis3)   lk_cpl      = ', lk_cpl 
     132         WRITE(numout,*) '              ocean-atmosphere coupled formulation       ln_cpl      = ', ln_cpl 
     133         WRITE(numout,*) '              forced-coupled mixed formulation           ln_mixcpl   = ', ln_mixcpl 
     134         WRITE(numout,*) '              OASIS coupling (with atm or sas)           lk_oasis    = ', lk_oasis 
     135         WRITE(numout,*) '              components of your executable              nn_components = ', nn_components 
    126136         WRITE(numout,*) '              Multicategory heat flux formulation (LIM3) nn_limflx   = ', nn_limflx 
    127137         WRITE(numout,*) '           Misc. options of sbc : ' 
     
    150160      END SELECT 
    151161      ! 
    152 #if defined key_top && ! defined key_offline 
    153       ltrcdm2dc = (ln_dm2dc .AND. ln_blk_core .AND. nn_ice==2) 
    154       IF( ltrcdm2dc )THEN 
    155          IF(lwp)THEN 
    156             WRITE(numout,*)"analytical diurnal cycle, core bulk formulation and LIM2 use: " 
    157             WRITE(numout,*)"Diurnal cycle on physics but not in passive tracers" 
    158          ENDIF 
    159       ENDIF 
    160 #else  
    161       ltrcdm2dc =  .FALSE. 
    162 #endif 
    163  
    164       ! 
     162      IF ( nn_components /= jp_iam_nemo .AND. .NOT. lk_oasis )   & 
     163         &      CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' ) 
     164      IF ( nn_components == jp_iam_opa .AND. ln_cpl )   & 
     165         &      CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but ln_cpl = T in OPA' ) 
     166      IF ( nn_components == jp_iam_opa .AND. ln_mixcpl )   & 
     167         &      CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' ) 
     168      IF ( ln_cpl .AND. .NOT. lk_oasis )    & 
     169         &      CALL ctl_stop( 'STOP', 'sbc_init : OASIS-coupled atmosphere model, but key_oasis3 disabled' ) 
     170      IF( ln_mixcpl .AND. .NOT. lk_oasis )    & 
     171         &      CALL ctl_stop( 'the forced-coupled mixed mode (ln_mixcpl) requires the cpp key key_oasis3' ) 
     172      IF( ln_mixcpl .AND. .NOT. ln_cpl )    & 
     173         &      CALL ctl_stop( 'the forced-coupled mixed mode (ln_mixcpl) requires ln_cpl = T' ) 
     174      IF( ln_mixcpl .AND. nn_components /= jp_iam_nemo )    & 
     175         &      CALL ctl_stop( 'the forced-coupled mixed mode (ln_mixcpl) is not yet working with sas-opa coupling via oasis' ) 
     176 
    165177      !                              ! allocate sbc arrays 
    166178      IF( sbc_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_oce arrays' ) 
    167179 
    168180      !                          ! Checks: 
    169       IF( .NOT. ln_rnf ) THEN                      ! no specific treatment in vicinity of river mouths  
    170          ln_rnf_mouth  = .false.                       
    171          IF( sbc_rnf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_rnf arrays' ) 
    172          nkrnf         = 0 
    173          rnf     (:,:) = 0.0_wp 
    174          rnf_b   (:,:) = 0.0_wp 
    175          rnfmsk  (:,:) = 0.0_wp 
    176          rnfmsk_z(:)   = 0.0_wp 
    177       ENDIF 
    178       IF( nn_isf .EQ. 0 ) THEN                      ! no specific treatment in vicinity of ice shelf  
     181      IF( nn_isf .EQ. 0 ) THEN                      ! variable initialisation if no ice shelf  
    179182         IF( sbc_isf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) 
    180183         fwfisf  (:,:) = 0.0_wp 
     184         fwfisf_b(:,:) = 0.0_wp 
     185         rdivisf       = 0.0_wp 
    181186      END IF 
    182       IF( nn_ice == 0  )   fr_i(:,:) = 0.e0        ! no ice in the domain, ice fraction is always zero 
     187      IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa )   fr_i(:,:) = 0.e0 ! no ice in the domain, ice fraction is always zero 
    183188 
    184189      sfx(:,:) = 0.0_wp                            ! the salt flux due to freezing/melting will be computed (i.e. will be non-zero)  
     
    190195 
    191196      !                                            ! restartability    
    192       IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR.   & 
    193           MOD( nstock             , nn_fsbc) /= 0 ) THEN  
    194          WRITE(ctmp1,*) 'experiment length (', nitend - nit000 + 1, ') or nstock (', nstock,   & 
    195             &           ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 
    196          CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 
    197       ENDIF 
    198       ! 
    199       IF( MOD( rday, REAL(nn_fsbc, wp) * rdt ) /= 0 )   & 
    200          &  CALL ctl_warn( 'nn_fsbc is NOT a multiple of the number of time steps in a day' ) 
    201       ! 
    202       IF( ( nn_ice == 2 .OR. nn_ice ==3 ) .AND. .NOT.( ln_blk_clio .OR. ln_blk_core .OR. lk_cpl ) )   & 
     197      IF( ( nn_ice == 2 .OR. nn_ice ==3 ) .AND. .NOT.( ln_blk_clio .OR. ln_blk_core .OR. ln_cpl ) )   & 
    203198         &   CALL ctl_stop( 'LIM sea-ice model requires a bulk formulation or coupled configuration' ) 
    204       IF( nn_ice == 4 .AND. .NOT.( ln_blk_core .OR. lk_cpl ) )   & 
    205          &   CALL ctl_stop( 'CICE sea-ice model requires ln_blk_core or lk_cpl' ) 
     199      IF( nn_ice == 4 .AND. .NOT.( ln_blk_core .OR. ln_cpl ) )   & 
     200         &   CALL ctl_stop( 'CICE sea-ice model requires ln_blk_core or ln_cpl' ) 
    206201      IF( nn_ice == 4 .AND. lk_agrif )   & 
    207202         &   CALL ctl_stop( 'CICE sea-ice model not currently available with AGRIF' ) 
     
    210205      IF( ( nn_ice /= 3 ) .AND. ( nn_limflx >= 0 ) )   & 
    211206         &   WRITE(numout,*) 'The nn_limflx>=0 option has no effect if sea ice model is not LIM3' 
    212       IF( ( nn_ice == 3 ) .AND. ( lk_cpl ) .AND. ( ( nn_limflx == -1 ) .OR. ( nn_limflx == 1 ) ) )   & 
     207      IF( ( nn_ice == 3 ) .AND. ( ln_cpl ) .AND. ( ( nn_limflx == -1 ) .OR. ( nn_limflx == 1 ) ) )   & 
    213208         &   CALL ctl_stop( 'The chosen nn_limflx for LIM3 in coupled mode must be 0 or 2' ) 
    214       IF( ( nn_ice == 3 ) .AND. ( .NOT. lk_cpl ) .AND. ( nn_limflx == 2 ) )   & 
     209      IF( ( nn_ice == 3 ) .AND. ( .NOT. ln_cpl ) .AND. ( nn_limflx == 2 ) )   & 
    215210         &   CALL ctl_stop( 'The chosen nn_limflx for LIM3 in forced mode cannot be 2' ) 
    216211 
    217212      IF( ln_dm2dc )   nday_qsr = -1   ! initialisation flag 
    218213 
    219       IF( ln_dm2dc .AND. .NOT.( ln_flx .OR. ln_blk_core ) )   & 
     214      IF( ln_dm2dc .AND. .NOT.( ln_flx .OR. ln_blk_core ) .AND. nn_components /= jp_iam_opa )   & 
    220215         &   CALL ctl_stop( 'diurnal cycle into qsr field from daily values requires a flux or core-bulk formulation' ) 
    221216       
    222       IF( ln_dm2dc .AND. ( ( NINT(rday) / ( nn_fsbc * NINT(rdt) ) )  < 8 ) )   & 
    223          &   CALL ctl_warn( 'diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) 
    224  
    225217      IF ( ln_wave ) THEN 
    226218      !Activated wave module but neither drag nor stokes drift activated 
     
    236228         & asked coupling with drag coefficient (ln_cdgw =T) or Stokes drift (ln_sdw=T) ') 
    237229      ENDIF  
    238        
    239230      !                          ! Choice of the Surface Boudary Condition (set nsbc) 
     231      ll_purecpl = ln_cpl .AND. .NOT. ln_mixcpl 
     232      ! 
    240233      icpt = 0 
    241       IF( ln_ana          ) THEN   ;   nsbc = jp_ana    ; icpt = icpt + 1   ;   ENDIF       ! analytical      formulation 
    242       IF( ln_flx          ) THEN   ;   nsbc = jp_flx    ; icpt = icpt + 1   ;   ENDIF       ! flux            formulation 
    243       IF( ln_blk_clio     ) THEN   ;   nsbc = jp_clio   ; icpt = icpt + 1   ;   ENDIF       ! CLIO bulk       formulation 
    244       IF( ln_blk_core     ) THEN   ;   nsbc = jp_core   ; icpt = icpt + 1   ;   ENDIF       ! CORE bulk       formulation 
    245       IF( ln_blk_mfs      ) THEN   ;   nsbc = jp_mfs    ; icpt = icpt + 1   ;   ENDIF       ! MFS  bulk       formulation 
    246       IF( lk_cpl          ) THEN   ;   nsbc = jp_cpl    ; icpt = icpt + 1   ;   ENDIF       ! Coupled         formulation 
    247       IF( cp_cfg == 'gyre') THEN   ;   nsbc = jp_gyre                       ;   ENDIF       ! GYRE analytical formulation 
    248       IF( lk_esopa        )            nsbc = jp_esopa                                      ! esopa test, ALL formulations 
     234      IF( ln_ana          ) THEN   ;   nsbc = jp_ana     ; icpt = icpt + 1   ;   ENDIF       ! analytical           formulation 
     235      IF( ln_flx          ) THEN   ;   nsbc = jp_flx     ; icpt = icpt + 1   ;   ENDIF       ! flux                 formulation 
     236      IF( ln_blk_clio     ) THEN   ;   nsbc = jp_clio    ; icpt = icpt + 1   ;   ENDIF       ! CLIO bulk            formulation 
     237      IF( ln_blk_core     ) THEN   ;   nsbc = jp_core    ; icpt = icpt + 1   ;   ENDIF       ! CORE bulk            formulation 
     238      IF( ln_blk_mfs      ) THEN   ;   nsbc = jp_mfs     ; icpt = icpt + 1   ;   ENDIF       ! MFS  bulk            formulation 
     239      IF( ll_purecpl      ) THEN   ;   nsbc = jp_purecpl ; icpt = icpt + 1   ;   ENDIF       ! Pure Coupled         formulation 
     240      IF( cp_cfg == 'gyre') THEN   ;   nsbc = jp_gyre                        ;   ENDIF       ! GYRE analytical      formulation 
     241      IF( nn_components == jp_iam_opa )   & 
     242         &                  THEN   ;   nsbc = jp_none    ; icpt = icpt + 1   ;   ENDIF       ! opa coupling via SAS module 
     243      IF( lk_esopa        )            nsbc = jp_esopa                                       ! esopa test, ALL formulations 
    249244      ! 
    250245      IF( icpt /= 1 .AND. .NOT.lk_esopa ) THEN 
     
    257252      IF(lwp) THEN 
    258253         WRITE(numout,*) 
    259          IF( nsbc == jp_esopa )   WRITE(numout,*) '              ESOPA test All surface boundary conditions' 
    260          IF( nsbc == jp_gyre  )   WRITE(numout,*) '              GYRE analytical formulation' 
    261          IF( nsbc == jp_ana   )   WRITE(numout,*) '              analytical formulation' 
    262          IF( nsbc == jp_flx   )   WRITE(numout,*) '              flux formulation' 
    263          IF( nsbc == jp_clio  )   WRITE(numout,*) '              CLIO bulk formulation' 
    264          IF( nsbc == jp_core  )   WRITE(numout,*) '              CORE bulk formulation' 
    265          IF( nsbc == jp_cpl   )   WRITE(numout,*) '              coupled formulation' 
    266          IF( nsbc == jp_mfs   )   WRITE(numout,*) '              MFS Bulk formulation' 
    267       ENDIF 
    268       ! 
     254         IF( nsbc == jp_esopa   )   WRITE(numout,*) '              ESOPA test All surface boundary conditions' 
     255         IF( nsbc == jp_gyre    )   WRITE(numout,*) '              GYRE analytical formulation' 
     256         IF( nsbc == jp_ana     )   WRITE(numout,*) '              analytical formulation' 
     257         IF( nsbc == jp_flx     )   WRITE(numout,*) '              flux formulation' 
     258         IF( nsbc == jp_clio    )   WRITE(numout,*) '              CLIO bulk formulation' 
     259         IF( nsbc == jp_core    )   WRITE(numout,*) '              CORE bulk formulation' 
     260         IF( nsbc == jp_purecpl )   WRITE(numout,*) '              pure coupled formulation' 
     261         IF( nsbc == jp_mfs     )   WRITE(numout,*) '              MFS Bulk formulation' 
     262         IF( nsbc == jp_none    )   WRITE(numout,*) '              OPA coupled to SAS via oasis' 
     263         IF( ln_mixcpl          )   WRITE(numout,*) '              + forced-coupled mixed formulation' 
     264         IF( nn_components/= jp_iam_nemo )  & 
     265            &                       WRITE(numout,*) '              + OASIS coupled SAS' 
     266      ENDIF 
     267      ! 
     268      IF( lk_oasis )   CALL sbc_cpl_init (nn_ice)   ! OASIS initialisation. must be done before: (1) first time step 
     269      !                                                     !                                            (2) the use of nn_fsbc 
     270 
     271!     nn_fsbc initialization if OPA-SAS coupling via OASIS 
     272!     sas model time step has to be declared in OASIS (mandatory) -> nn_fsbc has to be modified accordingly 
     273      IF ( nn_components /= jp_iam_nemo ) THEN 
     274 
     275         IF ( nn_components == jp_iam_opa ) nn_fsbc = cpl_freq('O_SFLX') / NINT(rdt) 
     276         IF ( nn_components == jp_iam_sas ) nn_fsbc = cpl_freq('I_SFLX') / NINT(rdt) 
     277         ! 
     278         IF(lwp)THEN 
     279            WRITE(numout,*) 
     280            WRITE(numout,*)"   OPA-SAS coupled via OASIS : nn_fsbc re-defined from OASIS namcouple ", nn_fsbc 
     281            WRITE(numout,*) 
     282         ENDIF 
     283      ENDIF 
     284 
     285      IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR.   & 
     286          MOD( nstock             , nn_fsbc) /= 0 ) THEN  
     287         WRITE(ctmp1,*) 'experiment length (', nitend - nit000 + 1, ') or nstock (', nstock,   & 
     288            &           ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 
     289         CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 
     290      ENDIF 
     291      ! 
     292      IF( MOD( rday, REAL(nn_fsbc, wp) * rdt ) /= 0 )   & 
     293         &  CALL ctl_warn( 'nn_fsbc is NOT a multiple of the number of time steps in a day' ) 
     294      ! 
     295      IF( ln_dm2dc .AND. ( ( NINT(rday) / ( nn_fsbc * NINT(rdt) ) )  < 8 ) )   & 
     296         &   CALL ctl_warn( 'diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) 
     297 
    269298                               CALL sbc_ssm_init               ! Sea-surface mean fields initialisation 
    270299      ! 
    271300      IF( ln_ssr           )   CALL sbc_ssr_init               ! Sea-Surface Restoring initialisation 
    272301      ! 
     302                               CALL sbc_rnf_init               ! Runof initialisation 
     303      ! 
     304      IF( nn_ice == 3      )   CALL sbc_lim_init               ! LIM3 initialisation 
     305 
    273306      IF( nn_ice == 4      )   CALL cice_sbc_init( nsbc )      ! CICE initialisation 
    274       ! 
    275       IF( nsbc   == jp_cpl )   CALL sbc_cpl_init (nn_ice)      ! OASIS initialisation. must be done before first time step 
    276  
     307       
    277308   END SUBROUTINE sbc_init 
    278309 
     
    314345      !                                            ! ---------------------------------------- ! 
    315346      ! 
    316       IF( ln_apr_dyn ) CALL sbc_apr( kt )                ! atmospheric pressure provided at kt+0.5*nn_fsbc 
     347      IF ( .NOT. lk_bdy ) then 
     348         IF( ln_apr_dyn ) CALL sbc_apr( kt )                ! atmospheric pressure provided at kt+0.5*nn_fsbc 
     349      ENDIF 
    317350                                                         ! (caution called before sbc_ssm) 
    318351      ! 
    319       CALL sbc_ssm( kt )                                 ! ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) 
    320       !                                                  ! averaged over nf_sbc time-step 
     352      IF( nn_components /= jp_iam_sas )   CALL sbc_ssm( kt )   ! ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) 
     353      !                                                        ! averaged over nf_sbc time-step 
    321354 
    322355      IF (ln_wave) CALL sbc_wave( kt ) 
     
    329362      CASE( jp_flx   )   ;   CALL sbc_flx     ( kt )                    ! flux formulation 
    330363      CASE( jp_clio  )   ;   CALL sbc_blk_clio( kt )                    ! bulk formulation : CLIO for the ocean 
    331       CASE( jp_core  )   ;   CALL sbc_blk_core( kt )                    ! bulk formulation : CORE for the ocean 
    332       CASE( jp_cpl   )   ;   CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice )   ! coupled formulation 
     364      CASE( jp_core  )    
     365         IF( nn_components == jp_iam_sas ) & 
     366            &                CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice )   ! OPA-SAS coupling: SAS receiving fields from OPA  
     367                             CALL sbc_blk_core( kt )                    ! bulk formulation : CORE for the ocean 
     368                                                                        ! from oce: sea surface variables (sst_m, sss_m,  ssu_m,  ssv_m) 
     369      CASE( jp_purecpl )  ;  CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice )   ! pure coupled formulation 
     370                                                                        ! 
    333371      CASE( jp_mfs   )   ;   CALL sbc_blk_mfs ( kt )                    ! bulk formulation : MFS for the ocean 
     372      CASE( jp_none  )  
     373         IF( nn_components == jp_iam_opa ) & 
     374                             CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice )   ! OPA-SAS coupling: OPA receiving fields from SAS 
    334375      CASE( jp_esopa )                                 
    335376                             CALL sbc_ana     ( kt )                    ! ESOPA, test ALL the formulations 
     
    341382      END SELECT 
    342383 
     384      IF( ln_mixcpl )        CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice )   ! forced-coupled mixed formulation after forcing 
     385 
     386 
    343387      !                                            !==  Misc. Options  ==! 
    344388       
     
    363407      !                                                           ! (update freshwater fluxes) 
    364408!RBbug do not understand why see ticket 667 
    365       !clem-bugsal CALL lbc_lnk( emp, 'T', 1. ) 
     409!clem: it looks like it is necessary for the north fold (in certain circumstances). Don't know why. 
     410      CALL lbc_lnk( emp, 'T', 1. ) 
    366411      ! 
    367412      IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    ! 
     
    404449         ! CALL iom_rstput( kt, nitrst, numrow, 'qsr_b'  , qsr  ) 
    405450         CALL iom_rstput( kt, nitrst, numrow, 'emp_b'  , emp  ) 
    406          CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx ) 
     451         CALL iom_rstput( kt, nitrst, numrow, 'sfx_b'  , sfx ) 
    407452      ENDIF 
    408453 
     
    419464         CALL iom_put( "qns"   , qns        )                   ! solar heat flux 
    420465         CALL iom_put( "qsr"   ,       qsr  )                   ! solar heat flux 
    421          IF( nn_ice > 0 )   CALL iom_put( "ice_cover", fr_i )   ! ice fraction  
     466         IF( nn_ice > 0 .OR. nn_components == jp_iam_opa )   CALL iom_put( "ice_cover", fr_i )   ! ice fraction  
    422467         CALL iom_put( "taum"  , taum       )                   ! wind stress module  
    423468         CALL iom_put( "wspd"  , wndm       )                   ! wind speed  module over free ocean or leads in presence of sea-ice 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r5038 r5620  
    3232 
    3333   PUBLIC   sbc_rnf       ! routine call in sbcmod module 
    34    PUBLIC   sbc_rnf_div   ! routine called in sshwzv module 
     34   PUBLIC   sbc_rnf_div   ! routine called in divcurl module 
    3535   PUBLIC   sbc_rnf_alloc ! routine call in sbcmod module 
    3636   PUBLIC   sbc_rnf_init  ! (PUBLIC for TAM) 
    3737   !                                                     !!* namsbc_rnf namelist * 
    38    CHARACTER(len=100), PUBLIC ::   cn_dir          !: Root directory for location of ssr files 
    39    LOGICAL           , PUBLIC ::   ln_rnf_depth    !: depth       river runoffs attribute specified in a file 
    40    LOGICAL           , PUBLIC ::   ln_rnf_tem      !: temperature river runoffs attribute specified in a file 
     38   CHARACTER(len=100)         ::   cn_dir          !: Root directory for location of rnf files 
     39   LOGICAL                    ::   ln_rnf_depth      !: depth       river runoffs attribute specified in a file 
     40   LOGICAL                    ::   ln_rnf_depth_ini  !: depth       river runoffs  computed at the initialisation 
     41   REAL(wp)                   ::   rn_rnf_max        !: maximum value of the runoff climatologie ( ln_rnf_depth_ini = .true ) 
     42   REAL(wp)                   ::   rn_dep_max        !: depth over which runoffs is spread ( ln_rnf_depth_ini = .true ) 
     43   INTEGER                    ::   nn_rnf_depth_file !: create (=1) a runoff depth file or not (=0) 
     44   LOGICAL                    ::   ln_rnf_tem      !: temperature river runoffs attribute specified in a file 
    4145   LOGICAL           , PUBLIC ::   ln_rnf_sal      !: salinity    river runoffs attribute specified in a file 
    42    LOGICAL           , PUBLIC ::   ln_rnf_emp      !: runoffs into a file to be read or already into precipitation 
    4346   TYPE(FLD_N)       , PUBLIC ::   sn_rnf          !: information about the runoff file to be read 
    44    TYPE(FLD_N)       , PUBLIC ::   sn_cnf          !: information about the runoff mouth file to be read 
     47   TYPE(FLD_N)               ::   sn_cnf          !: information about the runoff mouth file to be read 
    4548   TYPE(FLD_N)                ::   sn_s_rnf        !: information about the salinities of runoff file to be read 
    4649   TYPE(FLD_N)                ::   sn_t_rnf        !: information about the temperatures of runoff file to be read 
    4750   TYPE(FLD_N)                ::   sn_dep_rnf      !: information about the depth which river inflow affects 
    4851   LOGICAL           , PUBLIC ::   ln_rnf_mouth    !: specific treatment in mouths vicinity 
    49    REAL(wp)          , PUBLIC ::   rn_hrnf         !: runoffs, depth over which enhanced vertical mixing is used 
     52   REAL(wp)                  ::   rn_hrnf         !: runoffs, depth over which enhanced vertical mixing is used 
    5053   REAL(wp)          , PUBLIC ::   rn_avt_rnf      !: runoffs, value of the additional vertical mixing coef. [m2/s] 
    51    REAL(wp)          , PUBLIC ::   rn_rfact        !: multiplicative factor for runoff 
     54   REAL(wp)                   ::   rn_rfact        !: multiplicative factor for runoff 
     55 
     56   LOGICAL           , PUBLIC ::   l_rnfcpl = .false.       ! runoffs recieved from oasis 
    5257 
    5358   INTEGER , PUBLIC  ::   nkrnf = 0         !: nb of levels over which Kz is increased at river mouths 
     
    5863   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents   [K.m/s & PSU.m/s]    
    5964 
    60    TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
    61    TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
    62    TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
     65   TYPE(FLD),       ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
     66   TYPE(FLD),       ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
     67   TYPE(FLD),       ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
    6368  
    6469   !! * Substitutions   
     
    105110      CALL wrk_alloc( jpi,jpj, ztfrz) 
    106111 
    107       ! 
    108       IF( kt == nit000 )   CALL sbc_rnf_init                           ! Read namelist and allocate structures 
    109  
    110112      !                                            ! ---------------------------------------- ! 
    111113      IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
     
    116118      ENDIF 
    117119 
    118       !                                                   !-------------------! 
    119       IF( .NOT. ln_rnf_emp ) THEN                         !   Update runoff   ! 
    120          !                                                !-------------------! 
    121          ! 
    122                              CALL fld_read ( kt, nn_fsbc, sf_rnf   )    ! Read Runoffs data and provide it at kt 
    123          IF( ln_rnf_tem  )   CALL fld_read ( kt, nn_fsbc, sf_t_rnf )    ! idem for runoffs temperature if required 
    124          IF( ln_rnf_sal  )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required 
    125          ! 
    126          ! Runoff reduction only associated to the ORCA2_LIM configuration 
    127          ! when reading the NetCDF file runoff_1m_nomask.nc 
    128          IF( cp_cfg == 'orca' .AND. jp_cfg == 2 )   THEN 
    129             WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 
    130                sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 
     120      !                                            !-------------------! 
     121      !                                            !   Update runoff   ! 
     122      !                                            !-------------------! 
     123      ! 
     124      IF( .NOT. l_rnfcpl )   CALL fld_read ( kt, nn_fsbc, sf_rnf   )    ! Read Runoffs data and provide it at kt 
     125      IF(   ln_rnf_tem   )   CALL fld_read ( kt, nn_fsbc, sf_t_rnf )    ! idem for runoffs temperature if required 
     126      IF(   ln_rnf_sal   )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required 
     127      ! 
     128      ! Runoff reduction only associated to the ORCA2_LIM configuration 
     129      ! when reading the NetCDF file runoff_1m_nomask.nc 
     130      IF( cp_cfg == 'orca' .AND. jp_cfg == 2 .AND. .NOT. l_rnfcpl )   THEN 
     131         WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 
     132            sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 
     133         END WHERE 
     134      ENDIF 
     135      ! 
     136      IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 
     137         ! 
     138         IF( .NOT. l_rnfcpl )   rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) )       ! updated runoff value at time step kt 
     139         ! 
     140         !                                                     ! set temperature & salinity content of runoffs 
     141         IF( ln_rnf_tem ) THEN                                       ! use runoffs temperature data 
     142            rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
     143            WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp )             ! if missing data value use SST as runoffs temperature 
     144               rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    131145            END WHERE 
    132          ENDIF 
    133          ! 
    134          IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 
    135             ! 
    136             rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) )       ! updated runoff value at time step kt 
    137             ! 
    138             !                                                     ! set temperature & salinity content of runoffs 
    139             IF( ln_rnf_tem ) THEN                                       ! use runoffs temperature data 
    140                rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
    141                WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp )             ! if missing data value use SST as runoffs temperature 
    142                    rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    143                END WHERE 
    144                WHERE( sf_t_rnf(1)%fnow(:,:,1) == -222._wp )             ! where fwf comes from melting of ice shelves or iceberg 
    145                    ztfrz(:,:) = -1.9 !tfreez( sss_m(:,:) ) !PM to be discuss (trouble if sensitivity study) 
    146                    rnf_tsc(:,:,jp_tem) = ztfrz(:,:) * rnf(:,:) * r1_rau0 - rnf(:,:) * lfusisf * r1_rau0_rcp 
    147                END WHERE 
    148             ELSE                                                        ! use SST as runoffs temperature 
    149                rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    150             ENDIF 
    151             !                                                           ! use runoffs salinity data 
    152             IF( ln_rnf_sal )   rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
    153             !                                                           ! else use S=0 for runoffs (done one for all in the init) 
    154             IF ( ANY( rnf(:,:) < 0._wp ) ) z_err=1 
    155             IF(lk_mpp) CALL mpp_sum(z_err) 
    156             IF( z_err > 0 ) CALL ctl_stop( 'sbc_rnf : negative runnoff values exist' ) 
    157             ! 
    158             CALL iom_put( "runoffs", rnf )         ! output runoffs arrays 
    159          ENDIF 
    160          ! 
    161       ENDIF 
    162       ! 
     146            WHERE( sf_t_rnf(1)%fnow(:,:,1) == -222._wp )             ! where fwf comes from melting of ice shelves or iceberg 
     147               ztfrz(:,:) = -1.9 !tfreez( sss_m(:,:) ) !PM to be discuss (trouble if sensitivity study) 
     148               rnf_tsc(:,:,jp_tem) = ztfrz(:,:) * rnf(:,:) * r1_rau0 - rnf(:,:) * lfusisf * r1_rau0_rcp 
     149            END WHERE 
     150         ELSE                                                        ! use SST as runoffs temperature 
     151            rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
     152         ENDIF 
     153         !                                                           ! use runoffs salinity data 
     154         IF( ln_rnf_sal )   rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
     155         !                                                           ! else use S=0 for runoffs (done one for all in the init) 
     156         CALL iom_put( "runoffs", rnf )         ! output runoffs arrays 
     157      ENDIF 
     158      ! 
     159      !                                                ! ---------------------------------------- ! 
    163160      IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    ! 
    164161         !                                             ! ---------------------------------------- ! 
     
    171168         ELSE                                                   !* no restart: set from nit000 values 
    172169            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields set to nit000' 
    173              rnf_b    (:,:  ) = rnf    (:,:  ) 
    174              rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
     170            rnf_b    (:,:  ) = rnf    (:,:  ) 
     171            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
    175172         ENDIF 
    176173      ENDIF 
     
    186183         CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) 
    187184      ENDIF 
     185      ! 
    188186      CALL wrk_dealloc( jpi,jpj, ztfrz) 
    189187      ! 
     
    211209      zfact = 0.5_wp 
    212210      ! 
    213       IF( ln_rnf_depth ) THEN      !==   runoff distributed over several levels   ==! 
     211      IF( ln_rnf_depth .OR. ln_rnf_depth_ini ) THEN      !==   runoff distributed over several levels   ==! 
    214212         IF( lk_vvl ) THEN             ! variable volume case 
    215213            DO jj = 1, jpj                   ! update the depth over which runoffs are distributed 
     
    255253      !!---------------------------------------------------------------------- 
    256254      CHARACTER(len=32) ::   rn_dep_file   ! runoff file name 
    257       INTEGER           ::   ji, jj, jk    ! dummy loop indices 
     255      INTEGER           ::   ji, jj, jk, jm    ! dummy loop indices 
    258256      INTEGER           ::   ierror, inum  ! temporary integer 
    259257      INTEGER           ::   ios           ! Local integer output status for namelist read 
    260       ! 
    261       NAMELIST/namsbc_rnf/ cn_dir, ln_rnf_emp, ln_rnf_depth, ln_rnf_tem, ln_rnf_sal,   & 
     258      INTEGER           ::   nbrec         ! temporary integer 
     259      REAL(wp)          ::   zacoef   
     260      REAL(wp), DIMENSION(12)                 :: zrec             ! times records 
     261      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zrnfcl     
     262      REAL(wp), DIMENSION(:,:  ), ALLOCATABLE :: zrnf 
     263      ! 
     264      NAMELIST/namsbc_rnf/ cn_dir            , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal,   & 
    262265         &                 sn_rnf, sn_cnf    , sn_s_rnf    , sn_t_rnf  , sn_dep_rnf,   & 
    263          &                 ln_rnf_mouth      , rn_hrnf     , rn_avt_rnf, rn_rfact 
    264       !!---------------------------------------------------------------------- 
     266         &                 ln_rnf_mouth      , rn_hrnf     , rn_avt_rnf, rn_rfact,     & 
     267         &                 ln_rnf_depth_ini  , rn_dep_max  , rn_rnf_max, nn_rnf_depth_file 
     268      !!---------------------------------------------------------------------- 
     269      ! 
     270      !                                         !==  allocate runoff arrays 
     271      IF( sbc_rnf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) 
     272      ! 
     273      IF( .NOT. ln_rnf ) THEN                      ! no specific treatment in vicinity of river mouths  
     274         ln_rnf_mouth  = .FALSE.                   ! default definition needed for example by sbc_ssr or by tra_adv_muscl 
     275         nkrnf         = 0 
     276         rnf     (:,:) = 0.0_wp 
     277         rnf_b   (:,:) = 0.0_wp 
     278         rnfmsk  (:,:) = 0.0_wp 
     279         rnfmsk_z(:)   = 0.0_wp 
     280         RETURN 
     281      ENDIF 
    265282      ! 
    266283      !                                   ! ============ 
     
    283300         WRITE(numout,*) '~~~~~~~ ' 
    284301         WRITE(numout,*) '   Namelist namsbc_rnf' 
    285          WRITE(numout,*) '      runoff in a file to be read                ln_rnf_emp   = ', ln_rnf_emp 
    286302         WRITE(numout,*) '      specific river mouths treatment            ln_rnf_mouth = ', ln_rnf_mouth 
    287303         WRITE(numout,*) '      river mouth additional Kz                  rn_avt_rnf   = ', rn_avt_rnf 
     
    289305         WRITE(numout,*) '      multiplicative factor for runoff           rn_rfact     = ', rn_rfact 
    290306      ENDIF 
    291       ! 
    292307      !                                   ! ================== 
    293308      !                                   !   Type of runoff 
    294309      !                                   ! ================== 
    295       !                                         !==  allocate runoff arrays 
    296       IF( sbc_rnf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) 
    297       ! 
    298       IF( ln_rnf_emp ) THEN                     !==  runoffs directly provided in the precipitations  ==! 
    299          IF(lwp) WRITE(numout,*) 
    300          IF(lwp) WRITE(numout,*) '          runoffs directly provided in the precipitations' 
    301          IF( ln_rnf_depth .OR. ln_rnf_tem .OR. ln_rnf_sal ) THEN 
    302            CALL ctl_warn( 'runoffs already included in precipitations, so runoff (T,S, depth) attributes will not be used' ) 
    303            ln_rnf_depth = .FALSE.   ;   ln_rnf_tem = .FALSE.   ;   ln_rnf_sal = .FALSE. 
    304          ENDIF 
    305          ! 
    306       ELSE                                      !==  runoffs read in a file : set sf_rnf structure  ==! 
    307          ! 
     310      ! 
     311      IF( .NOT. l_rnfcpl ) THEN                     
    308312         ALLOCATE( sf_rnf(1), STAT=ierror )         ! Create sf_rnf structure (runoff inflow) 
    309313         IF(lwp) WRITE(numout,*) 
     
    314318         ALLOCATE( sf_rnf(1)%fnow(jpi,jpj,1)   ) 
    315319         IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,1,2) ) 
    316          !                                          ! fill sf_rnf with the namelist (sn_rnf) and control print 
    317320         CALL fld_fill( sf_rnf, (/ sn_rnf /), cn_dir, 'sbc_rnf_init', 'read runoffs data', 'namsbc_rnf' ) 
    318          ! 
    319          IF( ln_rnf_tem ) THEN                      ! Create (if required) sf_t_rnf structure 
    320             IF(lwp) WRITE(numout,*) 
    321             IF(lwp) WRITE(numout,*) '          runoffs temperatures read in a file' 
    322             ALLOCATE( sf_t_rnf(1), STAT=ierror  ) 
    323             IF( ierror > 0 ) THEN 
    324                CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' )   ;   RETURN 
    325             ENDIF 
    326             ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1)   ) 
    327             IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) 
    328             CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf' ) 
    329          ENDIF 
    330          ! 
    331          IF( ln_rnf_sal  ) THEN                     ! Create (if required) sf_s_rnf and sf_t_rnf structures 
    332             IF(lwp) WRITE(numout,*) 
    333             IF(lwp) WRITE(numout,*) '          runoffs salinities read in a file' 
    334             ALLOCATE( sf_s_rnf(1), STAT=ierror  ) 
    335             IF( ierror > 0 ) THEN 
    336                CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' )   ;   RETURN 
    337             ENDIF 
    338             ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1)   ) 
    339             IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) 
    340             CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf' ) 
    341          ENDIF 
    342          ! 
    343          IF( ln_rnf_depth ) THEN                    ! depth of runoffs set from a file 
    344             IF(lwp) WRITE(numout,*) 
    345             IF(lwp) WRITE(numout,*) '          runoffs depth read in a file' 
    346             rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) 
    347             IF( .NOT. sn_dep_rnf%ln_clim ) THEN   ;   WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear    ! add year  
    348                IF( sn_dep_rnf%cltype == 'monthly' )   WRITE(rn_dep_file, '(a,"m",i2)'  ) TRIM( rn_dep_file ), nmonth   ! add month  
    349             ENDIF  
    350             CALL iom_open ( rn_dep_file, inum )                           ! open file 
    351             CALL iom_get  ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf )   ! read the river mouth array 
    352             CALL iom_close( inum )                                        ! close file 
    353             ! 
    354             nk_rnf(:,:) = 0                               ! set the number of level over which river runoffs are applied 
    355             DO jj = 1, jpj 
    356                DO ji = 1, jpi 
    357                   IF( h_rnf(ji,jj) > 0._wp ) THEN 
    358                      jk = 2 
    359                      DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1 ;  END DO 
    360                      nk_rnf(ji,jj) = jk 
    361                   ELSEIF( h_rnf(ji,jj) == -1._wp   ) THEN   ;  nk_rnf(ji,jj) = 1 
    362                   ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN   ;  nk_rnf(ji,jj) = mbkt(ji,jj) 
    363                   ELSE 
    364                      CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999'  ) 
    365                      WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) 
    366                   ENDIF 
     321      ENDIF 
     322      ! 
     323      IF( ln_rnf_tem ) THEN                      ! Create (if required) sf_t_rnf structure 
     324         IF(lwp) WRITE(numout,*) 
     325         IF(lwp) WRITE(numout,*) '          runoffs temperatures read in a file' 
     326         ALLOCATE( sf_t_rnf(1), STAT=ierror  ) 
     327         IF( ierror > 0 ) THEN 
     328            CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' )   ;   RETURN 
     329         ENDIF 
     330         ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1)   ) 
     331         IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) 
     332         CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf' ) 
     333      ENDIF 
     334      ! 
     335      IF( ln_rnf_sal  ) THEN                     ! Create (if required) sf_s_rnf and sf_t_rnf structures 
     336         IF(lwp) WRITE(numout,*) 
     337         IF(lwp) WRITE(numout,*) '          runoffs salinities read in a file' 
     338         ALLOCATE( sf_s_rnf(1), STAT=ierror  ) 
     339         IF( ierror > 0 ) THEN 
     340            CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' )   ;   RETURN 
     341         ENDIF 
     342         ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1)   ) 
     343         IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) 
     344         CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf' ) 
     345      ENDIF 
     346      ! 
     347      IF( ln_rnf_depth ) THEN                    ! depth of runoffs set from a file 
     348         IF(lwp) WRITE(numout,*) 
     349         IF(lwp) WRITE(numout,*) '          runoffs depth read in a file' 
     350         rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) 
     351         IF( .NOT. sn_dep_rnf%ln_clim ) THEN   ;   WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear    ! add year  
     352            IF( sn_dep_rnf%cltype == 'monthly' )   WRITE(rn_dep_file, '(a,"m",i2)'  ) TRIM( rn_dep_file ), nmonth   ! add month  
     353         ENDIF 
     354         CALL iom_open ( rn_dep_file, inum )                           ! open file 
     355         CALL iom_get  ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf )   ! read the river mouth array 
     356         CALL iom_close( inum )                                        ! close file 
     357         ! 
     358         nk_rnf(:,:) = 0                               ! set the number of level over which river runoffs are applied 
     359         DO jj = 1, jpj 
     360            DO ji = 1, jpi 
     361               IF( h_rnf(ji,jj) > 0._wp ) THEN 
     362                  jk = 2 
     363                  DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1 
     364                  END DO 
     365                  nk_rnf(ji,jj) = jk 
     366               ELSEIF( h_rnf(ji,jj) == -1._wp   ) THEN   ;  nk_rnf(ji,jj) = 1 
     367               ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN   ;  nk_rnf(ji,jj) = mbkt(ji,jj) 
     368               ELSE 
     369                  CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999'  ) 
     370                  WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) 
     371               ENDIF 
     372            END DO 
     373         END DO 
     374         DO jj = 1, jpj                                ! set the associated depth 
     375            DO ji = 1, jpi 
     376               h_rnf(ji,jj) = 0._wp 
     377               DO jk = 1, nk_rnf(ji,jj) 
     378                  h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 
    367379               END DO 
    368380            END DO 
    369             DO jj = 1, jpj                                ! set the associated depth 
    370                DO ji = 1, jpi 
    371                   h_rnf(ji,jj) = 0._wp 
    372                   DO jk = 1, nk_rnf(ji,jj) 
    373                      h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 
     381         END DO 
     382         ! 
     383      ELSE IF( ln_rnf_depth_ini ) THEN           ! runoffs applied at the surface 
     384         ! 
     385         IF(lwp) WRITE(numout,*) 
     386         IF(lwp) WRITE(numout,*) '    depth of runoff computed once from max value of runoff' 
     387         IF(lwp) WRITE(numout,*) '    max value of the runoff climatologie (over global domain) rn_rnf_max = ', rn_rnf_max 
     388         IF(lwp) WRITE(numout,*) '    depth over which runoffs is spread                        rn_dep_max = ', rn_dep_max 
     389         IF(lwp) WRITE(numout,*) '     create (=1) a runoff depth file or not (=0)      nn_rnf_depth_file  = ', nn_rnf_depth_file 
     390 
     391         CALL iom_open( TRIM( sn_rnf%clname ), inum )    !  open runoff file 
     392         CALL iom_gettime( inum, zrec, kntime=nbrec) 
     393         ALLOCATE( zrnfcl(jpi,jpj,nbrec) )     ;      ALLOCATE( zrnf(jpi,jpj) ) 
     394         DO jm = 1, nbrec 
     395            CALL iom_get( inum, jpdom_data, TRIM( sn_rnf%clvar ), zrnfcl(:,:,jm), jm ) 
     396         END DO 
     397         CALL iom_close( inum ) 
     398         zrnf(:,:) = MAXVAL( zrnfcl(:,:,:), DIM=3 )   !  maximum value in time 
     399         DEALLOCATE( zrnfcl ) 
     400         ! 
     401         h_rnf(:,:) = 1. 
     402         ! 
     403         zacoef = rn_dep_max / rn_rnf_max            ! coef of linear relation between runoff and its depth (150m for max of runoff) 
     404         ! 
     405         WHERE( zrnf(:,:) > 0._wp )  h_rnf(:,:) = zacoef * zrnf(:,:)   ! compute depth for all runoffs 
     406         ! 
     407         DO jj = 1, jpj                     ! take in account min depth of ocean rn_hmin 
     408            DO ji = 1, jpi 
     409               IF( zrnf(ji,jj) > 0._wp ) THEN 
     410                  jk = mbkt(ji,jj) 
     411                  h_rnf(ji,jj) = MIN( h_rnf(ji,jj), gdept_0(ji,jj,jk ) ) 
     412               ENDIF 
     413            END DO 
     414         END DO 
     415         ! 
     416         nk_rnf(:,:) = 0                       ! number of levels on which runoffs are distributed 
     417         DO jj = 1, jpj 
     418            DO ji = 1, jpi 
     419               IF( zrnf(ji,jj) > 0._wp ) THEN 
     420                  jk = 2 
     421                  DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1 
    374422                  END DO 
     423                  nk_rnf(ji,jj) = jk 
     424               ELSE 
     425                  nk_rnf(ji,jj) = 1 
     426               ENDIF 
     427            END DO 
     428         END DO 
     429         ! 
     430         DEALLOCATE( zrnf ) 
     431         ! 
     432         DO jj = 1, jpj                                ! set the associated depth 
     433            DO ji = 1, jpi 
     434               h_rnf(ji,jj) = 0._wp 
     435               DO jk = 1, nk_rnf(ji,jj) 
     436                  h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 
    375437               END DO 
    376438            END DO 
    377          ELSE                                       ! runoffs applied at the surface 
    378             nk_rnf(:,:) = 1 
    379             h_rnf (:,:) = fse3t(:,:,1) 
    380          ENDIF 
    381          ! 
     439         END DO 
     440         ! 
     441         IF( nn_rnf_depth_file == 1 ) THEN      !  save  output nb levels for runoff 
     442            IF(lwp) WRITE(numout,*) '              create runoff depht file' 
     443            CALL iom_open  ( TRIM( sn_dep_rnf%clname ), inum, ldwrt = .TRUE., kiolib = jprstlib ) 
     444            CALL iom_rstput( 0, 0, inum, 'rodepth', h_rnf ) 
     445            CALL iom_close ( inum ) 
     446         ENDIF 
     447      ELSE                                       ! runoffs applied at the surface 
     448         nk_rnf(:,:) = 1 
     449         h_rnf (:,:) = fse3t(:,:,1) 
    382450      ENDIF 
    383451      ! 
     
    400468         IF( rn_hrnf > 0._wp ) THEN 
    401469            nkrnf = 2 
    402             DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf )   ;   nkrnf = nkrnf + 1   ;   END DO 
     470            DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf )   ;   nkrnf = nkrnf + 1 
     471            END DO 
    403472            IF( ln_sco )   CALL ctl_warn( 'sbc_rnf: number of levels over which Kz is increased is computed for zco...' ) 
    404473         ENDIF 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90

    r5038 r5620  
    5858      REAL(wp) ::   zcoef, zf_sbc       ! local scalar 
    5959      REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts 
    60       REAL(wp), DIMENSION(jpi,jpj)      :: zub, zvb,zdep 
    6160      !!--------------------------------------------------------------------- 
    62        
    63       !                                        !* first wet T-, U-, V- ocean level (ISF) variables (T, S, depth, velocity) 
     61 
     62      !                                        !* surface T-, U-, V- ocean level variables (T, S, depth, velocity) 
    6463      DO jj = 1, jpj 
    6564         DO ji = 1, jpi 
    66             zub(ji,jj)        = ub (ji,jj,miku(ji,jj)) 
    67             zvb(ji,jj)        = vb (ji,jj,mikv(ji,jj)) 
    6865            zts(ji,jj,jp_tem) = tsn(ji,jj,mikt(ji,jj),jp_tem) 
    6966            zts(ji,jj,jp_sal) = tsn(ji,jj,mikt(ji,jj),jp_sal) 
     
    7168      END DO 
    7269      ! 
    73       IF( lk_vvl ) THEN 
    74          DO jj = 1, jpj 
    75             DO ji = 1, jpi 
    76                zdep(ji,jj) = fse3t_n(ji,jj,mikt(ji,jj)) 
    77             END DO 
    78          END DO 
    79       ENDIF 
    80       !                                                   ! ---------------------------------------- ! 
    8170      IF( nn_fsbc == 1 ) THEN                             !   Instantaneous surface fields        ! 
    8271         !                                                ! ---------------------------------------- ! 
    83          ssu_m(:,:) = zub(:,:) 
    84          ssv_m(:,:) = zvb(:,:) 
     72         ssu_m(:,:) = ub(:,:,1) 
     73         ssv_m(:,:) = vb(:,:,1) 
    8574         IF( ln_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    8675         ELSE                    ;   sst_m(:,:) = zts(:,:,jp_tem) 
     
    9281         ENDIF 
    9382         ! 
    94          IF( lk_vvl )   fse3t_m(:,:) = zdep(:,:) 
     83         IF( lk_vvl )   e3t_m(:,:) = fse3t_n(:,:,1) 
     84         ! 
     85         frq_m(:,:) = fraqsr_1lev(:,:) 
    9586         ! 
    9687      ELSE 
     
    10192            IF(lwp) WRITE(numout,*) '~~~~~~~   mean fields initialised to instantaneous values' 
    10293            zcoef = REAL( nn_fsbc - 1, wp ) 
    103             ssu_m(:,:) = zcoef * zub(:,:) 
    104             ssv_m(:,:) = zcoef * zvb(:,:) 
     94            ssu_m(:,:) = zcoef * ub(:,:,1) 
     95            ssv_m(:,:) = zcoef * vb(:,:,1) 
    10596            IF( ln_useCT )  THEN    ;   sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    10697            ELSE                    ;   sst_m(:,:) = zcoef * zts(:,:,jp_tem) 
     
    112103            ENDIF 
    113104            ! 
    114             IF( lk_vvl )   fse3t_m(:,:) = zcoef * zdep(:,:) 
     105            IF( lk_vvl )   e3t_m(:,:) = zcoef * fse3t_n(:,:,1) 
     106            ! 
     107            frq_m(:,:) = zcoef * fraqsr_1lev(:,:) 
    115108            !                                             ! ---------------------------------------- ! 
    116109         ELSEIF( MOD( kt - 2 , nn_fsbc ) == 0 ) THEN      !   Initialisation: New mean computation   ! 
     
    121114            sss_m(:,:) = 0.e0 
    122115            ssh_m(:,:) = 0.e0 
    123             IF( lk_vvl )   fse3t_m(:,:) = 0.e0 
     116            IF( lk_vvl )   e3t_m(:,:) = 0.e0 
     117            frq_m(:,:) = 0.e0 
    124118         ENDIF 
    125119         !                                                ! ---------------------------------------- ! 
    126120         !                                                !        Cumulate at each time step        ! 
    127121         !                                                ! ---------------------------------------- ! 
    128          ssu_m(:,:) = ssu_m(:,:) + zub(:,:) 
    129          ssv_m(:,:) = ssv_m(:,:) + zvb(:,:) 
     122         ssu_m(:,:) = ssu_m(:,:) + ub(:,:,1) 
     123         ssv_m(:,:) = ssv_m(:,:) + vb(:,:,1) 
    130124         IF( ln_useCT )  THEN    ;   sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    131125         ELSE                    ;   sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem) 
     
    137131         ENDIF 
    138132         ! 
    139          IF( lk_vvl )   fse3t_m(:,:) = fse3t_m(:,:) + zdep(:,:) 
     133         IF( lk_vvl )   e3t_m(:,:) = fse3t_m(:,:) + fse3t_n(:,:,1) 
     134         ! 
     135         frq_m(:,:) =   frq_m(:,:) + fraqsr_1lev(:,:) 
    140136 
    141137         !                                                ! ---------------------------------------- ! 
     
    148144            ssv_m(:,:) = ssv_m(:,:) * zcoef           ! 
    149145            ssh_m(:,:) = ssh_m(:,:) * zcoef           ! mean SSH             [m] 
    150             IF( lk_vvl )   fse3t_m(:,:) = fse3t_m(:,:) * zcoef   ! mean vertical scale factor [m] 
     146            IF( lk_vvl )   e3t_m(:,:) = fse3t_m(:,:) * zcoef   ! mean vertical scale factor [m] 
     147            frq_m(:,:) = frq_m(:,:) * zcoef   ! mean fraction of solar net radiation absorbed in the 1st T level [-] 
    151148            ! 
    152149         ENDIF 
     
    165162            CALL iom_rstput( kt, nitrst, numrow, 'sss_m'  , sss_m  ) 
    166163            CALL iom_rstput( kt, nitrst, numrow, 'ssh_m'  , ssh_m  ) 
    167             IF( lk_vvl ) THEN 
    168                CALL iom_rstput( kt, nitrst, numrow, 'fse3t_m'  , fse3t_m(:,:)  ) 
    169             END IF 
    170             ! 
    171          ENDIF 
    172          ! 
     164            IF( lk_vvl )   CALL iom_rstput( kt, nitrst, numrow, 'e3t_m'  , e3t_m  ) 
     165            CALL iom_rstput( kt, nitrst, numrow, 'frq_m'  , frq_m  ) 
     166            ! 
     167         ENDIF 
     168         ! 
     169      ENDIF 
     170      ! 
     171      IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN          !   Mean value at each nn_fsbc time-step   ! 
     172         CALL iom_put( 'ssu_m', ssu_m ) 
     173         CALL iom_put( 'ssv_m', ssv_m ) 
     174         CALL iom_put( 'sst_m', sst_m ) 
     175         CALL iom_put( 'sss_m', sss_m ) 
     176         CALL iom_put( 'ssh_m', ssh_m ) 
     177         IF( lk_vvl )   CALL iom_put( 'e3t_m', e3t_m ) 
     178         CALL iom_put( 'frq_m', frq_m ) 
    173179      ENDIF 
    174180      ! 
     
    206212            CALL iom_get( numror, jpdom_autoglo, 'sss_m'  , sss_m  )   !   "         "    salinity    (T-point) 
    207213            CALL iom_get( numror, jpdom_autoglo, 'ssh_m'  , ssh_m  )   !   "         "    height      (T-point) 
    208             IF( lk_vvl ) CALL iom_get( numror, jpdom_autoglo, 'fse3t_m', fse3t_m(:,:) ) 
     214            IF( lk_vvl ) CALL iom_get( numror, jpdom_autoglo, 'e3t_m', e3t_m ) 
     215            ! fraction of solar net radiation absorbed in 1st T level 
     216            IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN 
     217               CALL iom_get( numror, jpdom_autoglo, 'frq_m'  , frq_m  ) 
     218            ELSE 
     219               frq_m(:,:) = 1._wp   ! default definition 
     220            ENDIF 
    209221            ! 
    210222            IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN      ! nn_fsbc has changed between 2 runs 
     
    217229               sss_m(:,:) = zcoef * sss_m(:,:) 
    218230               ssh_m(:,:) = zcoef * ssh_m(:,:) 
    219                IF( lk_vvl ) fse3t_m(:,:) = zcoef * fse3t_m(:,:) 
     231               IF( lk_vvl )   e3t_m(:,:) = zcoef * fse3t_m(:,:) 
     232               frq_m(:,:) = zcoef * frq_m(:,:) 
    220233            ELSE 
    221234               IF(lwp) WRITE(numout,*) '~~~~~~~   mean fields read in the ocean restart file' 
     
    224237      ENDIF 
    225238      ! 
     239      IF( .NOT. l_ssm_mean ) THEN   ! default initialisation. needed by lim_istate 
     240         ! 
     241         IF(lwp) WRITE(numout,*) '          default initialisation of ss?_m arrays' 
     242         ssu_m(:,:) = ub(:,:,1) 
     243         ssv_m(:,:) = vb(:,:,1) 
     244         IF( ln_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 
     245         ELSE                    ;   sst_m(:,:) = tsn(:,:,1,jp_tem) 
     246         ENDIF 
     247         sss_m(:,:) = tsn(:,:,1,jp_sal) 
     248         ssh_m(:,:) = sshn(:,:) 
     249         IF( lk_vvl )   e3t_m(:,:) = fse3t_n(:,:,1) 
     250         frq_m(:,:) = 1._wp 
     251         ! 
     252      ENDIF 
     253      ! 
    226254   END SUBROUTINE sbc_ssm_init 
    227255 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbctide.F90

    • Property svn:keywords set to Id
    r4292 r5620  
    3636   !!---------------------------------------------------------------------- 
    3737   !! NEMO/OPA 3.5 , NEMO Consortium (2013) 
    38    !! $Id: $ 
     38   !! $Id$ 
    3939   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4040   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90

    • Property svn:keywords set to Id
    r4792 r5620  
    3939   !!---------------------------------------------------------------------- 
    4040   !! NEMO/OPA 4.0 , NEMO Consortium (2011)  
    41    !! $Id: $ 
     41   !! $Id$ 
    4242   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4343   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/tide_mod.F90

    • Property svn:keywords set to Id
    r4292 r5620  
    3535   !!---------------------------------------------------------------------- 
    3636   !! NEMO/OPA 3.3 , LOCEAN-IPSL (2010)  
    37    !! $Id:$  
     37   !! $Id$  
    3838   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    3939   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/tideini.F90

    • Property svn:keywords set to Id
    r4792 r5620  
    3636   !!---------------------------------------------------------------------- 
    3737   !! NEMO/OPA 3.5 , NEMO Consortium (2013) 
    38    !! $Id: $ 
     38   !! $Id$ 
    3939   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4040   !!---------------------------------------------------------------------- 
     
    8080          END DO 
    8181       END DO 
     82       !        
     83       ! Ensure that tidal components have been set in namelist_cfg 
     84       IF( nb_harmo .EQ. 0 ) CALL ctl_stop( 'tide_init : No tidal components set in nam_tide' ) 
    8285       ! 
    8386       IF(lwp) THEN 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/updtide.F90

    • Property svn:keywords set to Id
    r4292 r5620  
    2626   !!---------------------------------------------------------------------- 
    2727   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    28    !! $Id: sbcfwb.F90 3625 2012-11-21 13:19:18Z acc $ 
     28   !! $Id$ 
    2929   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3030   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SOL/solver.F90

    r4792 r5620  
    9292      IF( .NOT. lk_agrif .OR. .NOT. ln_rstart) THEN 
    9393         IF( sol_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'solver_init : unable to allocate sol_oce arrays' ) 
     94         gcx (:,:) = 0.e0 
     95         gcxb(:,:) = 0.e0 
    9496      ENDIF 
    9597 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/STO/stopar.F90

    r5488 r5620  
    849849 
    850850 
    851    REAL(wp) FUNCTION sto_par_flt_fac( kpasses ) 
     851   FUNCTION sto_par_flt_fac( kpasses ) 
    852852      !!---------------------------------------------------------------------- 
    853853      !!                  ***  FUNCTION sto_par_flt_fac  *** 
     
    858858      !!---------------------------------------------------------------------- 
    859859      INTEGER, INTENT(in) :: kpasses 
     860      REAL(wp) :: sto_par_flt_fac 
    860861      !! 
    861862      INTEGER :: jpasses, ji, jj, jflti, jfltj 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r5038 r5620  
    2222   !!             -   ! 2013-04  (F. Roquet, G. Madec)  add eos_rab, change bn2 computation and reorganize the module 
    2323   !!             -   ! 2014-09  (F. Roquet)  add TEOS-10, S-EOS, and modify EOS-80 
     24   !!             -   ! 2015-06  (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF 
    2425   !!---------------------------------------------------------------------- 
    2526 
     
    4748   USE lbclnk         ! ocean lateral boundary conditions 
    4849   USE timing          ! Timing 
     50   USE stopar          ! Stochastic T/S fluctuations 
     51   USE stopts          ! Stochastic T/S fluctuations 
    4952 
    5053   IMPLICIT NONE 
     
    7275   PUBLIC   eos_init       ! called by istate module 
    7376 
    74    !                                          !!* Namelist (nameos) * 
    75    INTEGER , PUBLIC ::   nn_eos   = 0         !: = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 
    76    LOGICAL , PUBLIC ::   ln_useCT  = .FALSE. ! determine if eos_pt_from_ct is used to compute sst_m 
     77   !                                !!* Namelist (nameos) * 
     78   INTEGER , PUBLIC ::   nn_eos     ! = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 
     79   LOGICAL , PUBLIC ::   ln_useCT  ! determine if eos_pt_from_ct is used to compute sst_m 
    7780 
    7881   !                                   !!!  simplified eos coefficients 
     
    313316      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
    314317      ! 
    315       INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    316       REAL(wp) ::   zt , zh , zs , ztm        ! local scalars 
    317       REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      - 
     318      INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
     319      INTEGER  ::   jdof 
     320      REAL(wp) ::   zt , zh , zstemp, zs , ztm   ! local scalars 
     321      REAL(wp) ::   zn , zn0, zn1, zn2, zn3      !   -      - 
     322      REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign    ! local vectors 
    318323      !!---------------------------------------------------------------------- 
    319324      ! 
     
    324329      CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    325330         ! 
    326          DO jk = 1, jpkm1 
    327             DO jj = 1, jpj 
    328                DO ji = 1, jpi 
    329                   ! 
    330                   zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    331                   zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    332                   zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    333                   ztm = tmask(ji,jj,jk)                                         ! tmask 
    334                   ! 
    335                   zn3 = EOS013*zt   & 
    336                      &   + EOS103*zs+EOS003 
    337                      ! 
    338                   zn2 = (EOS022*zt   & 
    339                      &   + EOS112*zs+EOS012)*zt   & 
    340                      &   + (EOS202*zs+EOS102)*zs+EOS002 
    341                      ! 
    342                   zn1 = (((EOS041*zt   & 
    343                      &   + EOS131*zs+EOS031)*zt   & 
    344                      &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
    345                      &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
    346                      &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
    347                      ! 
    348                   zn0 = (((((EOS060*zt   & 
    349                      &   + EOS150*zs+EOS050)*zt   & 
    350                      &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
    351                      &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
    352                      &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
    353                      &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
    354                      &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
    355                      ! 
    356                   zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    357                   ! 
    358                   prhop(ji,jj,jk) = zn0 * ztm                           ! potential density referenced at the surface 
    359                   ! 
    360                   prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm      ! density anomaly (masked) 
     331         ! Stochastic equation of state 
     332         IF ( ln_sto_eos ) THEN 
     333            ALLOCATE(zn0_sto(1:2*nn_sto_eos)) 
     334            ALLOCATE(zn_sto(1:2*nn_sto_eos)) 
     335            ALLOCATE(zsign(1:2*nn_sto_eos)) 
     336            DO jsmp = 1, 2*nn_sto_eos, 2 
     337              zsign(jsmp)   = 1._wp 
     338              zsign(jsmp+1) = -1._wp 
     339            END DO 
     340            ! 
     341            DO jk = 1, jpkm1 
     342               DO jj = 1, jpj 
     343                  DO ji = 1, jpi 
     344                     ! 
     345                     ! compute density (2*nn_sto_eos) times: 
     346                     ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts) 
     347                     ! (2) for t-dt, s-ds (with the opposite fluctuation) 
     348                     DO jsmp = 1, nn_sto_eos*2 
     349                        jdof   = (jsmp + 1) / 2 
     350                        zh     = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     351                        zt     = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0    ! temperature 
     352                        zstemp = pts  (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp) 
     353                        zs     = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 )   ! square root salinity 
     354                        ztm    = tmask(ji,jj,jk)                                         ! tmask 
     355                        ! 
     356                        zn3 = EOS013*zt   & 
     357                           &   + EOS103*zs+EOS003 
     358                           ! 
     359                        zn2 = (EOS022*zt   & 
     360                           &   + EOS112*zs+EOS012)*zt   & 
     361                           &   + (EOS202*zs+EOS102)*zs+EOS002 
     362                           ! 
     363                        zn1 = (((EOS041*zt   & 
     364                           &   + EOS131*zs+EOS031)*zt   & 
     365                           &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
     366                           &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
     367                           &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
     368                           ! 
     369                        zn0_sto(jsmp) = (((((EOS060*zt   & 
     370                           &   + EOS150*zs+EOS050)*zt   & 
     371                           &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     372                           &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     373                           &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     374                           &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     375                           &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     376                           ! 
     377                        zn_sto(jsmp)  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp) 
     378                     END DO 
     379                     ! 
     380                     ! compute stochastic density as the mean of the (2*nn_sto_eos) densities 
     381                     prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp 
     382                     DO jsmp = 1, nn_sto_eos*2 
     383                        prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp)                      ! potential density referenced at the surface 
     384                        ! 
     385                        prd(ji,jj,jk) = prd(ji,jj,jk) + (  zn_sto(jsmp) * r1_rau0 - 1._wp  )   ! density anomaly (masked) 
     386                     END DO 
     387                     prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos 
     388                     prd  (ji,jj,jk) = 0.5_wp * prd  (ji,jj,jk) * ztm / nn_sto_eos 
     389                  END DO 
    361390               END DO 
    362391            END DO 
    363          END DO 
    364          ! 
     392            DEALLOCATE(zn0_sto,zn_sto,zsign) 
     393         ! Non-stochastic equation of state 
     394         ELSE 
     395            DO jk = 1, jpkm1 
     396               DO jj = 1, jpj 
     397                  DO ji = 1, jpi 
     398                     ! 
     399                     zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     400                     zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     401                     zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     402                     ztm = tmask(ji,jj,jk)                                         ! tmask 
     403                     ! 
     404                     zn3 = EOS013*zt   & 
     405                        &   + EOS103*zs+EOS003 
     406                        ! 
     407                     zn2 = (EOS022*zt   & 
     408                        &   + EOS112*zs+EOS012)*zt   & 
     409                        &   + (EOS202*zs+EOS102)*zs+EOS002 
     410                        ! 
     411                     zn1 = (((EOS041*zt   & 
     412                        &   + EOS131*zs+EOS031)*zt   & 
     413                        &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
     414                        &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
     415                        &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
     416                        ! 
     417                     zn0 = (((((EOS060*zt   & 
     418                        &   + EOS150*zs+EOS050)*zt   & 
     419                        &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     420                        &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     421                        &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     422                        &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     423                        &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     424                        ! 
     425                     zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     426                     ! 
     427                     prhop(ji,jj,jk) = zn0 * ztm                           ! potential density referenced at the surface 
     428                     ! 
     429                     prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm      ! density anomaly (masked) 
     430                  END DO 
     431               END DO 
     432            END DO 
     433         ENDIF 
     434          
    365435      CASE( 1 )                !==  simplified EOS  ==! 
    366436         ! 
     
    922992 
    923993 
    924    FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf ) 
     994   SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
    925995      !!---------------------------------------------------------------------- 
    926996      !!                 ***  ROUTINE eos_fzp  *** 
     
    9361006      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
    9371007      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
    938       REAL(wp), DIMENSION(jpi,jpj)                          ::   ptf   ! freezing temperature [Celcius] 
     1008      REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celcius] 
    9391009      ! 
    9401010      INTEGER  ::   ji, jj   ! dummy loop indices 
     
    9691039         nstop = nstop + 1 
    9701040         ! 
    971       END SELECT 
    972       ! 
    973    END FUNCTION eos_fzp_2d 
    974  
    975   FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf ) 
     1041      END SELECT       
     1042      ! 
     1043  END SUBROUTINE eos_fzp_2d 
     1044 
     1045  SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) 
    9761046      !!---------------------------------------------------------------------- 
    9771047      !!                 ***  ROUTINE eos_fzp  *** 
     
    9851055      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    9861056      !!---------------------------------------------------------------------- 
    987       REAL(wp), INTENT(in)           ::   psal   ! salinity   [psu] 
    988       REAL(wp), INTENT(in), OPTIONAL ::   pdep   ! depth      [m] 
    989       REAL(wp)                       ::   ptf   ! freezing temperature [Celcius] 
     1057      REAL(wp), INTENT(in )           ::   psal         ! salinity   [psu] 
     1058      REAL(wp), INTENT(in ), OPTIONAL ::   pdep         ! depth      [m] 
     1059      REAL(wp), INTENT(out)           ::   ptf          ! freezing temperature [Celcius] 
    9901060      ! 
    9911061      REAL(wp) :: zs   ! local scalars 
     
    10171087      END SELECT 
    10181088      ! 
    1019    END FUNCTION eos_fzp_0d 
     1089   END SUBROUTINE eos_fzp_0d 
    10201090 
    10211091 
     
    11831253            WRITE(numout,*) '             model uses Conservative Temperature' 
    11841254            WRITE(numout,*) '             Important: model must be initialized with CT and SA fields' 
     1255         ELSE 
     1256            WRITE(numout,*) '             model does not use Conservative Temperature' 
    11851257         ENDIF 
    11861258      ENDIF 
     
    15891661      END SELECT 
    15901662      ! 
     1663      rau0_rcp    = rau0 * rcp  
    15911664      r1_rau0     = 1._wp / rau0 
    15921665      r1_rcp      = 1._wp / rcp 
    1593       r1_rau0_rcp = 1._wp / ( rau0 * rcp ) 
     1666      r1_rau0_rcp = 1._wp / rau0_rcp  
    15941667      ! 
    15951668      IF(lwp) WRITE(numout,*) 
     
    15971670      IF(lwp) WRITE(numout,*) '          1. / rau0                        r1_rau0  = ', r1_rau0, ' m^3/kg' 
    15981671      IF(lwp) WRITE(numout,*) '          ocean specific heat                 rcp   = ', rcp    , ' J/Kelvin' 
     1672      IF(lwp) WRITE(numout,*) '          rau0 * rcp                       rau0_rcp = ', rau0_rcp 
    15991673      IF(lwp) WRITE(numout,*) '          1. / ( rau0 * rcp )           r1_rau0_rcp = ', r1_rau0_rcp 
    16001674      ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90

    r5038 r5620  
    2626   USE cla             ! cross land advection      (cla_traadv     routine) 
    2727   USE ldftra_oce      ! lateral diffusion coefficient on tracers 
     28   ! 
    2829   USE in_out_manager  ! I/O manager 
    2930   USE iom             ! I/O module 
     
    3334   USE timing          ! Timing 
    3435   USE sbc_oce 
     36   USE diaptr          ! Poleward heat transport  
    3537 
    3638 
     
    111113      ! 
    112114      IF( ln_mle    )   CALL tra_adv_mle( kt, nit000, zun, zvn, zwn, 'TRA' )    ! add the mle transport (if necessary) 
     115      ! 
    113116      CALL iom_put( "uocetr_eff", zun )                                         ! output effective transport       
    114117      CALL iom_put( "vocetr_eff", zvn ) 
    115118      CALL iom_put( "wocetr_eff", zwn ) 
    116  
     119      ! 
     120      IF( ln_diaptr )   CALL dia_ptr( zvn )                                     ! diagnose the effective MSF  
     121      ! 
     122    
    117123      SELECT CASE ( nadv )                            !==  compute advection trend and add it to general trend  ==! 
    118       CASE ( 1 )   ;    CALL tra_adv_cen2  ( kt, nit000, 'TRA',         zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  2nd order centered 
    119       CASE ( 2 )   ;    CALL tra_adv_tvd   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD  
    120       CASE ( 3 )   ;    CALL tra_adv_muscl ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb,      tsa, jpts, ln_traadv_msc_ups )   !  MUSCL  
    121       CASE ( 4 )   ;    CALL tra_adv_muscl2( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  MUSCL2  
    122       CASE ( 5 )   ;    CALL tra_adv_ubs   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  UBS  
    123       CASE ( 6 )   ;    CALL tra_adv_qck   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  QUICKEST  
    124       CASE ( 7 )   ;   CALL tra_adv_tvd_zts( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD ZTS 
     124      CASE ( 1 )   ;    CALL tra_adv_cen2   ( kt, nit000, 'TRA',         zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  2nd order centered 
     125      CASE ( 2 )   ;    CALL tra_adv_tvd    ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD  
     126      CASE ( 3 )   ;    CALL tra_adv_muscl  ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb,      tsa, jpts, ln_traadv_msc_ups )   !  MUSCL  
     127      CASE ( 4 )   ;    CALL tra_adv_muscl2 ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  MUSCL2  
     128      CASE ( 5 )   ;    CALL tra_adv_ubs    ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  UBS  
     129      CASE ( 6 )   ;    CALL tra_adv_qck    ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  QUICKEST  
     130      CASE ( 7 )   ;    CALL tra_adv_tvd_zts( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD ZTS 
    125131      ! 
    126132      CASE (-1 )                                      !==  esopa: test all possibility with control print  ==! 
     
    206212      IF( lk_esopa         )   ioptio =          1 
    207213 
    208       IF( ( ln_traadv_muscl .OR. ln_traadv_muscl2 .OR. ln_traadv_ubs .OR. ln_traadv_qck ) .AND. nn_isf .NE. 0 )  & 
    209       &   CALL ctl_stop( 'Only traadv_cen2 and traadv_tvd is compatible with ice shelf cavity') 
     214      IF( ( ln_traadv_muscl .OR. ln_traadv_muscl2 .OR. ln_traadv_ubs .OR. ln_traadv_qck .OR. ln_traadv_tvd_zts )   & 
     215         .AND. ln_isfcav )   CALL ctl_stop( 'Only traadv_cen2 and traadv_tvd is compatible with ice shelf cavity') 
    210216 
    211217      IF( ioptio /= 1 )   CALL ctl_stop( 'Choose ONE advection scheme in namelist namtra_adv' ) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90

    r5038 r5620  
    173173         END DO  
    174174      END DO  
    175       zfzp(:,:) = eos_fzp( tsn(:,:,1,jp_sal), zpres(:,:) ) 
     175      CALL eos_fzp( tsn(:,:,1,jp_sal), zfzp(:,:), zpres(:,:) ) 
    176176      DO jk = 1, jpk 
    177177         DO jj = 1, jpj 
     
    279279         END IF 
    280280         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    281          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    282            IF( jn == jp_tem )   htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    283            IF( jn == jp_sal )   str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     281         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     282           IF( jn == jp_tem )   htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     283           IF( jn == jp_sal )   str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    284284         ENDIF 
    285285         ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_mle.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    5353   !!---------------------------------------------------------------------- 
    5454   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    55    !! $Id:$ 
     55   !! $Id$ 
    5656   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    5757   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90

    r5038 r5620  
    2121   USE trdtra         ! tracers trends manager 
    2222   USE dynspg_oce     ! choice/control of key cpp for surface pressure gradient 
    23    USE sbcrnf          ! river runoffs 
     23   USE sbcrnf         ! river runoffs 
    2424   USE diaptr         ! poleward transport diagnostics 
    2525   ! 
     
    219219         END IF 
    220220         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    221          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    222             IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    223             IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     221         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     222            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     223            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    224224         ENDIF 
    225225 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl2.F90

    r5038 r5620  
    200200 
    201201         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    202          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
    203             IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    204             IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     202         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
     203            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     204            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    205205         ENDIF 
    206206 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90

    r5038 r5620  
    355355         IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 
    356356         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    357          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    358            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    359            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     357         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     358           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     359           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    360360         ENDIF 
    361361         ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r5038 r5620  
    106106      ENDIF 
    107107      ! 
    108       zwi(:,:,:) = 0.e0 ; zwz(:,:,:) = 0.e0 
     108      zwi(:,:,:) = 0.e0 ;  
    109109      ! 
    110110      !                                                          ! =========== 
    111111      DO jn = 1, kjpt                                            ! tracer loop 
    112112         !                                                       ! =========== 
    113          ! 1. Bottom value : flux set to zero 
     113         ! 1. Bottom and k=1 value : flux set to zero 
    114114         ! ---------------------------------- 
    115115         zwx(:,:,jpk) = 0.e0    ;    zwz(:,:,jpk) = 0.e0 
    116116         zwy(:,:,jpk) = 0.e0    ;    zwi(:,:,jpk) = 0.e0 
    117  
     117           
     118         zwz(:,:,1  ) = 0._wp 
    118119         ! 2. upstream advection with initial mass fluxes & intermediate update 
    119120         ! -------------------------------------------------------------------- 
     
    134135 
    135136         ! upstream tracer flux in the k direction 
     137         ! Interior value 
     138         DO jk = 2, jpkm1 
     139            DO jj = 1, jpj 
     140               DO ji = 1, jpi 
     141                  zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
     142                  zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
     143                  zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk) 
     144               END DO 
     145            END DO 
     146         END DO 
    136147         ! Surface value 
    137148         IF( lk_vvl ) THEN    
    138             DO jj = 1, jpj 
    139                DO ji = 1, jpi 
    140                   zwz(ji,jj, mikt(ji,jj) ) = 0.e0                         ! volume variable 
    141                END DO 
    142             END DO 
     149            IF ( ln_isfcav ) THEN 
     150               DO jj = 1, jpj 
     151                  DO ji = 1, jpi 
     152                     zwz(ji,jj, mikt(ji,jj) ) = 0.e0          ! volume variable 
     153                  END DO 
     154               END DO 
     155            ELSE 
     156               zwz(:,:,1) = 0.e0          ! volume variable 
     157            END IF 
    143158         ELSE                 
    144             DO jj = 1, jpj 
    145                DO ji = 1, jpi 
    146                   zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface  
    147                END DO 
    148             END DO    
     159            IF ( ln_isfcav ) THEN 
     160               DO jj = 1, jpj 
     161                  DO ji = 1, jpi 
     162                     zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface  
     163                  END DO 
     164               END DO    
     165            ELSE 
     166               zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)   ! linear free surface 
     167            END IF 
    149168         ENDIF 
    150          ! Interior value 
    151          DO jj = 1, jpj 
    152             DO ji = 1, jpi 
    153                DO jk = mikt(ji,jj)+1, jpkm1 
    154                   zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
    155                   zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
    156                   zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) 
    157                END DO 
    158             END DO 
    159          END DO 
    160169 
    161170         ! total advective trend 
     
    184193         END IF 
    185194         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    186          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    187            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    188            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     195         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     196           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     197           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    189198         ENDIF 
    190199 
     
    202211       
    203212         ! antidiffusive flux on k 
    204          zwz(:,:,1) = 0.e0         ! Surface value 
    205          ! 
    206          DO jj = 1, jpj 
    207             DO ji = 1, jpi 
    208                ik=mikt(ji,jj) 
    209                ! surface value 
    210                zwz(ji,jj,1:ik) = 0.e0 
    211                ! Interior value 
    212                DO jk = mikt(ji,jj)+1, jpkm1                     
     213         ! Interior value 
     214         DO jk = 2, jpkm1                     
     215            DO jj = 1, jpj 
     216               DO ji = 1, jpi 
    213217                  zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) 
    214218               END DO 
    215219            END DO 
    216220         END DO 
     221         ! surface value 
     222         IF ( ln_isfcav ) THEN 
     223            DO jj = 1, jpj 
     224               DO ji = 1, jpi 
     225                  zwz(ji,jj,mikt(ji,jj)) = 0.e0 
     226               END DO 
     227            END DO 
     228         ELSE 
     229            zwz(:,:,1) = 0.e0 
     230         END IF 
    217231         CALL lbc_lnk( zwx, 'U', -1. )   ;   CALL lbc_lnk( zwy, 'V', -1. )         ! Lateral bondary conditions 
    218232         CALL lbc_lnk( zwz, 'W',  1. ) 
     
    250264         END IF 
    251265         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    252          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    253            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) + htr_adv(:) 
    254            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) + str_adv(:) 
     266         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     267           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
     268           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
    255269         ENDIF 
    256270         ! 
     
    358372 
    359373         ! upstream tracer flux in the k direction 
    360          ! Surface value 
    361          IF( lk_vvl ) THEN   ;   zwz(:,:, 1 ) = 0._wp                        ! volume variable 
    362          ELSE                ;   zwz(:,:, 1 ) = pwn(:,:,1) * ptb(:,:,1,jn)   ! linear free surface  
    363          ENDIF 
    364374         ! Interior value 
    365375         DO jk = 2, jpkm1 
     
    372382            END DO 
    373383         END DO 
     384         ! Surface value 
     385         IF( lk_vvl ) THEN 
     386            IF ( ln_isfcav ) THEN 
     387               DO jj = 1, jpj 
     388                  DO ji = 1, jpi 
     389                     zwz(ji,jj, mikt(ji,jj) ) = 0.e0          ! volume variable +    isf 
     390                  END DO 
     391               END DO 
     392            ELSE 
     393               zwz(:,:,1) = 0.e0                              ! volume variable + no isf 
     394            END IF 
     395         ELSE 
     396            IF ( ln_isfcav ) THEN 
     397               DO jj = 1, jpj 
     398                  DO ji = 1, jpi 
     399                     zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface +    isf 
     400                  END DO 
     401               END DO 
     402            ELSE 
     403               zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)                                               ! linear free surface + no isf 
     404            END IF 
     405         ENDIF 
    374406 
    375407         ! total advective trend 
     
    398430         END IF 
    399431         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    400          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    401            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    402            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     432         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     433           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     434           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    403435         ENDIF 
    404436 
     
    524556         END IF 
    525557         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    526          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    527            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) + htr_adv(:) 
    528            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) + str_adv(:) 
     558         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     559           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
     560           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
    529561         ENDIF 
    530562         ! 
     
    580612         &        paft * tmask + zbig * ( 1._wp - tmask )  ) 
    581613 
    582       DO jj = 2, jpjm1 
    583          DO ji = fs_2, fs_jpim1   ! vector opt. 
    584             DO jk = mikt(ji,jj), jpkm1 
    585                ikm1 = MAX(jk-1,mikt(ji,jj)) 
    586                z2dtt = p2dt(jk) 
    587                 
     614      DO jk = 1, jpkm1 
     615         ikm1 = MAX(jk-1,1) 
     616         z2dtt = p2dt(jk) 
     617         DO jj = 2, jpjm1 
     618            DO ji = fs_2, fs_jpim1   ! vector opt. 
     619 
    588620               ! search maximum in neighbourhood 
    589621               zup = MAX(  zbup(ji  ,jj  ,jk  ),   & 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90

    r5038 r5620  
    177177         END IF 
    178178         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    179          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    180             IF( jn == jp_tem )  htr_adv(:) = ptr_vj( ztv(:,:,:) ) 
    181             IF( jn == jp_sal )  str_adv(:) = ptr_vj( ztv(:,:,:) ) 
     179         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     180            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( ztv(:,:,:) ) 
     181            IF( jn == jp_sal )  str_adv(:) = ptr_sj( ztv(:,:,:) ) 
    182182         ENDIF 
    183183          
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90

    r5038 r5620  
    2121   USE trdtra          ! trends manager: tracers  
    2222   USE in_out_manager  ! I/O manager 
     23   USE iom             ! I/O manager 
     24   USE fldread         ! read input fields 
     25   USE lbclnk            ! ocean lateral boundary conditions (or mpp link) 
     26   USE lib_mpp           ! distributed memory computing library 
    2327   USE prtctl          ! Print control 
    2428   USE wrk_nemo        ! Memory Allocation 
     
    3741 
    3842   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   qgh_trd0   ! geothermal heating trend 
     43   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_qgh              ! structure of input qgh (file informations, fields read) 
    3944  
    4045   !! * Substitutions 
     
    4247   !!---------------------------------------------------------------------- 
    4348   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    44    !! $Id $  
     49   !! $Id$ 
    4550   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4651   !!---------------------------------------------------------------------- 
     
    9297      END DO 
    9398      ! 
     99      CALL lbc_lnk( tsa(:,:,:,jp_tem) , 'T', 1. ) 
     100      ! 
    94101      IF( l_trdtra ) THEN        ! Save the geothermal heat flux trend for diagnostics 
    95102         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
     
    125132      INTEGER  ::   inum                ! temporary logical unit 
    126133      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    127       ! 
    128       NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst  
     134      INTEGER  ::   ierror              ! local integer 
     135      ! 
     136      TYPE(FLD_N)        ::   sn_qgh    ! informations about the geotherm. field to be read 
     137      CHARACTER(len=256) ::   cn_dir    ! Root directory for location of ssr files 
     138      ! 
     139      NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir  
    129140      !!---------------------------------------------------------------------- 
    130141 
     
    161172         CASE ( 2 )                          !* variable geothermal heat flux : read the geothermal fluxes in mW/m2 
    162173            IF(lwp) WRITE(numout,*) '      *** variable geothermal heat flux' 
    163             CALL iom_open ( 'geothermal_heating.nc', inum ) 
    164             CALL iom_get  ( inum, jpdom_data, 'heatflow', qgh_trd0 ) 
    165             CALL iom_close( inum ) 
    166             qgh_trd0(:,:) = r1_rau0_rcp * qgh_trd0(:,:) * 1.e-3     ! conversion in W/m2 
     174            ! 
     175            ALLOCATE( sf_qgh(1), STAT=ierror ) 
     176            IF( ierror > 0 ) THEN 
     177               CALL ctl_stop( 'tra_bbc_init: unable to allocate sf_qgh structure' )   ; 
     178               RETURN 
     179            ENDIF 
     180            ALLOCATE( sf_qgh(1)%fnow(jpi,jpj,1)   ) 
     181            IF( sn_qgh%ln_tint )ALLOCATE( sf_qgh(1)%fdta(jpi,jpj,1,2) ) 
     182            ! fill sf_chl with sn_chl and control print 
     183            CALL fld_fill( sf_qgh, (/ sn_qgh /), cn_dir, 'tra_bbc_init',   & 
     184               &          'bottom temperature boundary condition', 'nambbc' ) 
     185 
     186            CALL fld_read( nit000, 1, sf_qgh )                         ! Read qgh data 
     187            qgh_trd0(:,:) = r1_rau0_rcp * sf_qgh(1)%fnow(:,:,1) * 1.e-3 ! conversion in W/m2 
    167188            ! 
    168189         CASE DEFAULT 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90

    r5038 r5620  
    2121   !!   tra_dmp       : update the tracer trend with the internal damping 
    2222   !!   tra_dmp_init  : initialization, namlist read, parameters control 
    23    !!   dtacof_zoom   : restoring coefficient for zoom domain 
    24    !!   dtacof        : restoring coefficient for global domain 
    25    !!   cofdis        : compute the distance to the coastline 
    2623   !!---------------------------------------------------------------------- 
    2724   USE oce            ! ocean: variables 
     
    3936   USE wrk_nemo       ! Memory allocation 
    4037   USE timing         ! Timing 
     38   USE iom 
    4139 
    4240   IMPLICIT NONE 
     
    4543   PUBLIC   tra_dmp      ! routine called by step.F90 
    4644   PUBLIC   tra_dmp_init ! routine called by opa.F90 
    47    PUBLIC   dtacof       ! routine called by tradmp.F90, trcdmp.F90 and dyndmp.F90 
    48    PUBLIC   dtacof_zoom  ! routine called by tradmp.F90, trcdmp.F90 and dyndmp.F90 
    49  
    50 !!gm  why all namelist variable public????   only ln_tradmp should be sufficient 
    5145 
    5246   !                               !!* Namelist namtra_dmp : T & S newtonian damping * 
     47   ! nn_zdmp and cn_resto are public as they are used by C1D/dyndmp.F90 
    5348   LOGICAL , PUBLIC ::   ln_tradmp   !: internal damping flag 
    54    INTEGER , PUBLIC ::   nn_hdmp     ! = 0/-1/'latitude' for damping over T and S 
    5549   INTEGER , PUBLIC ::   nn_zdmp     ! = 0/1/2 flag for damping in the mixed layer 
    56    REAL(wp), PUBLIC ::   rn_surf     ! surface time scale for internal damping        [days] 
    57    REAL(wp), PUBLIC ::   rn_bot      ! bottom time scale for internal damping         [days] 
    58    REAL(wp), PUBLIC ::   rn_dep      ! depth of transition between rn_surf and rn_bot [meters] 
    59    INTEGER , PUBLIC ::   nn_file     ! = 1 create a damping.coeff NetCDF file  
     50   CHARACTER(LEN=200) , PUBLIC :: cn_resto      ! name of netcdf file containing restoration coefficient field 
     51   ! 
     52 
    6053 
    6154   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   strdmp   !: damping salinity trend (psu/s) 
     
    197190      !! ** Method  :   read the namtra_dmp namelist and check the parameters 
    198191      !!---------------------------------------------------------------------- 
    199       INTEGER  ::   ios   ! Local integer output status for namelist read 
    200       !! 
    201       NAMELIST/namtra_dmp/ ln_tradmp, nn_hdmp, nn_zdmp, rn_surf, rn_bot, rn_dep, nn_file 
    202       !!---------------------------------------------------------------------- 
    203       ! 
    204       REWIND( numnam_ref )              ! Namelist namtra_dmp in reference namelist : Temperature and salinity damping term 
     192      NAMELIST/namtra_dmp/ ln_tradmp, nn_zdmp, cn_resto 
     193      INTEGER ::  ios         ! Local integer for output status of namelist read 
     194      INTEGER :: imask        ! File handle  
     195      !! 
     196      !!---------------------------------------------------------------------- 
     197      ! 
     198      REWIND( numnam_ref )   ! Namelist namtra_dmp in reference namelist : T & S relaxation 
    205199      READ  ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) 
    206200901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist', lwp ) 
    207201      ! 
    208       REWIND( numnam_cfg )              ! Namelist namtra_dmp in configuration namelist : Temperature and salinity damping term 
     202      REWIND( numnam_cfg )   ! Namelist namtra_dmp in configuration namelist : T & S relaxation 
    209203      READ  ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) 
    210204902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist', lwp ) 
    211205      IF(lwm) WRITE ( numond, namtra_dmp ) 
    212        
    213       IF( lzoom .AND. .NOT. lk_c1d )   nn_zdmp = 0          ! restoring to climatology at closed north or south boundaries 
    214  
    215       IF(lwp) THEN                       ! Namelist print 
     206 
     207      IF(lwp) THEN                 !Namelist print 
    216208         WRITE(numout,*) 
    217          WRITE(numout,*) 'tra_dmp_init : T and S newtonian damping' 
     209         WRITE(numout,*) 'tra_dmp_init : T and S newtonian relaxation' 
    218210         WRITE(numout,*) '~~~~~~~' 
    219          WRITE(numout,*) '   Namelist namtra_dmp : set damping parameter' 
    220          WRITE(numout,*) '      add a damping term or not       ln_tradmp = ', ln_tradmp 
    221          WRITE(numout,*) '      T and S damping option          nn_hdmp   = ', nn_hdmp 
    222          WRITE(numout,*) '      mixed layer damping option      nn_zdmp   = ', nn_zdmp, '(non-C1D zoom: forced to 0)' 
    223          WRITE(numout,*) '      surface time scale (days)       rn_surf   = ', rn_surf 
    224          WRITE(numout,*) '      bottom time scale (days)        rn_bot    = ', rn_bot 
    225          WRITE(numout,*) '      depth of transition (meters)    rn_dep    = ', rn_dep 
    226          WRITE(numout,*) '      create a damping.coeff file     nn_file   = ', nn_file 
     211         WRITE(numout,*) '   Namelist namtra_dmp : set relaxation parameters' 
     212         WRITE(numout,*) '      Apply relaxation   or not       ln_tradmp = ', ln_tradmp 
     213         WRITE(numout,*) '      mixed layer damping option      nn_zdmp   = ', nn_zdmp 
     214         WRITE(numout,*) '      Damping file name               cn_resto  = ', cn_resto 
    227215         WRITE(numout,*) 
    228216      ENDIF 
    229217 
    230       IF( ln_tradmp ) THEN               ! initialization for T-S damping 
    231          ! 
     218      IF( ln_tradmp) THEN 
     219         ! 
     220         !Allocate arrays 
    232221         IF( tra_dmp_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' ) 
    233          ! 
    234 !!gm  I don't understand the specificities of c1d case......    
    235 !!gm  to be check with the autor of these lines 
    236           
    237 #if ! defined key_c1d 
    238          SELECT CASE ( nn_hdmp ) 
    239          CASE (  -1  )   ;   IF(lwp) WRITE(numout,*) '   tracer damping in the Med & Red seas only' 
    240          CASE ( 1:90 )   ;   IF(lwp) WRITE(numout,*) '   tracer damping poleward of', nn_hdmp, ' degrees' 
    241          CASE DEFAULT 
    242             WRITE(ctmp1,*) '          bad flag value for nn_hdmp = ', nn_hdmp 
    243             CALL ctl_stop(ctmp1) 
     222 
     223         !Check values of nn_zdmp 
     224         SELECT CASE (nn_zdmp) 
     225         CASE ( 0 )  ; IF(lwp) WRITE(numout,*) '   tracer damping as specified by mask' 
     226         CASE ( 1 )  ; IF(lwp) WRITE(numout,*) '   no tracer damping in the turbocline' 
     227         CASE ( 2 )  ; IF(lwp) WRITE(numout,*) '   no tracer damping in the mixed layer' 
    244228         END SELECT 
    245          ! 
    246 #endif 
    247          SELECT CASE ( nn_zdmp ) 
    248          CASE ( 0 )   ;   IF(lwp) WRITE(numout,*) '   tracer damping throughout the water column' 
    249          CASE ( 1 )   ;   IF(lwp) WRITE(numout,*) '   no tracer damping in the turbocline (avt > 5 cm2/s)' 
    250          CASE ( 2 )   ;   IF(lwp) WRITE(numout,*) '   no tracer damping in the mixed layer' 
    251          CASE DEFAULT 
    252             WRITE(ctmp1,*) 'bad flag value for nn_zdmp = ', nn_zdmp 
    253             CALL ctl_stop(ctmp1) 
    254          END SELECT 
    255          ! 
     229 
     230         !TG: Initialisation of dtatsd - Would it be better to have dmpdta routine 
     231         !so can damp to something other than intitial conditions files? 
    256232         IF( .NOT.ln_tsd_tradmp ) THEN 
    257233            CALL ctl_warn( 'tra_dmp_init: read T-S data not initialized, we force ln_tsd_tradmp=T' ) 
    258234            CALL dta_tsd_init( ld_tradmp=ln_tradmp )        ! forces the initialisation of T-S data 
    259235         ENDIF 
    260          ! 
    261          strdmp(:,:,:) = 0._wp       ! internal damping salinity trend (used in asmtrj) 
     236 
     237         !initialise arrays - Are these actually used anywhere else? 
     238         strdmp(:,:,:) = 0._wp 
    262239         ttrdmp(:,:,:) = 0._wp 
    263          !                          ! Damping coefficients initialization 
    264          IF( lzoom .AND. .NOT. lk_c1d ) THEN   ;   CALL dtacof_zoom( resto ) 
    265          ELSE               ;   CALL dtacof( nn_hdmp, rn_surf, rn_bot, rn_dep, nn_file, 'TRA', resto ) 
    266          ENDIF 
    267          ! 
    268       ENDIF 
    269       ! 
     240 
     241         !Read in mask from file 
     242         CALL iom_open ( cn_resto, imask) 
     243         CALL iom_get  ( imask, jpdom_autoglo, 'resto', resto) 
     244         CALL iom_close( imask ) 
     245       ENDIF 
     246 
    270247   END SUBROUTINE tra_dmp_init 
    271248 
    272  
    273    SUBROUTINE dtacof_zoom( presto ) 
    274       !!---------------------------------------------------------------------- 
    275       !!                  ***  ROUTINE dtacof_zoom  *** 
    276       !! 
    277       !! ** Purpose :   Compute the damping coefficient for zoom domain 
    278       !! 
    279       !! ** Method  : - set along closed boundary due to zoom a damping over 
    280       !!                6 points with a max time scale of 5 days. 
    281       !!              - ORCA arctic/antarctic zoom: set the damping along 
    282       !!                south/north boundary over a latitude strip. 
    283       !! 
    284       !! ** Action  : - resto, the damping coeff. for T and S 
    285       !!---------------------------------------------------------------------- 
    286       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)  ::   presto   ! restoring coeff. (s-1) 
    287       ! 
    288       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    289       REAL(wp) ::   zlat, zlat0, zlat1, zlat2, z1_5d   ! local scalar 
    290       REAL(wp), DIMENSION(6)  ::   zfact               ! 1Dworkspace 
    291       !!---------------------------------------------------------------------- 
    292       ! 
    293       IF( nn_timing == 1 )  CALL timing_start( 'dtacof_zoom') 
    294       ! 
    295  
    296       zfact(1) =  1._wp 
    297       zfact(2) =  1._wp 
    298       zfact(3) = 11._wp / 12._wp 
    299       zfact(4) =  8._wp / 12._wp 
    300       zfact(5) =  4._wp / 12._wp 
    301       zfact(6) =  1._wp / 12._wp 
    302       zfact(:) = zfact(:) / ( 5._wp * rday )    ! 5 days max restoring time scale 
    303  
    304       presto(:,:,:) = 0._wp 
    305  
    306       ! damping along the forced closed boundary over 6 grid-points 
    307       DO jn = 1, 6 
    308          IF( lzoom_w )   presto( mi0(jn+jpizoom):mi1(jn+jpizoom), : , : )                    = zfact(jn)   ! west  closed 
    309          IF( lzoom_s )   presto( : , mj0(jn+jpjzoom):mj1(jn+jpjzoom), : )                    = zfact(jn)   ! south closed  
    310          IF( lzoom_e )   presto( mi0(jpiglo+jpizoom-1-jn):mi1(jpiglo+jpizoom-1-jn) , : , : ) = zfact(jn)   ! east  closed  
    311          IF( lzoom_n )   presto( : , mj0(jpjglo+jpjzoom-1-jn):mj1(jpjglo+jpjzoom-1-jn) , : ) = zfact(jn)   ! north closed 
    312       END DO 
    313  
    314       !                                           ! ==================================================== 
    315       IF( cp_cfz == "arctic" .OR. cp_cfz == "antarctic" ) THEN   !  ORCA configuration : arctic or antarctic zoom 
    316          !                                        ! ==================================================== 
    317          IF(lwp) WRITE(numout,*) 
    318          IF(lwp .AND. cp_cfz == "arctic" ) WRITE(numout,*) '              dtacof_zoom : ORCA    Arctic zoom' 
    319          IF(lwp .AND. cp_cfz == "antarctic" ) WRITE(numout,*) '           dtacof_zoom : ORCA Antarctic zoom' 
    320          IF(lwp) WRITE(numout,*) 
    321          ! 
    322          !                          ! Initialization :  
    323          presto(:,:,:) = 0._wp 
    324          zlat0 = 10._wp                     ! zlat0 : latitude strip where resto decreases 
    325          zlat1 = 30._wp                     ! zlat1 : resto = 1 before zlat1 
    326          zlat2 = zlat1 + zlat0              ! zlat2 : resto decreases from 1 to 0 between zlat1 and zlat2 
    327          z1_5d = 1._wp / ( 5._wp * rday )   ! z1_5d : 1 / 5days 
    328  
    329          DO jk = 2, jpkm1           ! Compute arrays resto ; value for internal damping : 5 days 
    330             DO jj = 1, jpj 
    331                DO ji = 1, jpi 
    332                   zlat = ABS( gphit(ji,jj) ) 
    333                   IF( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN 
    334                      presto(ji,jj,jk) = 0.5_wp * z1_5d * (  1._wp - COS( rpi*(zlat2-zlat)/zlat0 )  )  
    335                   ELSEIF( zlat < zlat1 ) THEN 
    336                      presto(ji,jj,jk) = z1_5d 
    337                   ENDIF 
    338                END DO 
    339             END DO 
    340          END DO 
    341          ! 
    342       ENDIF 
    343       !                             ! Mask resto array 
    344       presto(:,:,:) = presto(:,:,:) * tmask(:,:,:) 
    345       ! 
    346       IF( nn_timing == 1 )  CALL timing_stop( 'dtacof_zoom') 
    347       ! 
    348    END SUBROUTINE dtacof_zoom 
    349  
    350  
    351    SUBROUTINE dtacof( kn_hdmp, pn_surf, pn_bot, pn_dep,  & 
    352       &               kn_file, cdtype , presto           ) 
    353       !!---------------------------------------------------------------------- 
    354       !!                  ***  ROUTINE dtacof  *** 
    355       !! 
    356       !! ** Purpose :   Compute the damping coefficient 
    357       !! 
    358       !! ** Method  :   Arrays defining the damping are computed for each grid 
    359       !!                point for temperature and salinity (resto) 
    360       !!                Damping depends on distance to coast, depth and latitude 
    361       !! 
    362       !! ** Action  : - resto, the damping coeff. for T and S 
    363       !!---------------------------------------------------------------------- 
    364       USE iom 
    365       USE ioipsl 
    366       !! 
    367       INTEGER                         , INTENT(in   )  ::  kn_hdmp    ! damping option 
    368       REAL(wp)                        , INTENT(in   )  ::  pn_surf    ! surface time scale (days) 
    369       REAL(wp)                        , INTENT(in   )  ::  pn_bot     ! bottom time scale (days) 
    370       REAL(wp)                        , INTENT(in   )  ::  pn_dep     ! depth of transition (meters) 
    371       INTEGER                         , INTENT(in   )  ::  kn_file    ! save the damping coef on a file or not 
    372       CHARACTER(len=3)                , INTENT(in   )  ::  cdtype     ! =TRA, TRC or DYN (tracer/dynamics indicator) 
    373       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)  ::  presto     ! restoring coeff. (s-1) 
    374       ! 
    375       INTEGER  ::   ji, jj, jk                  ! dummy loop indices 
    376       INTEGER  ::   ii0, ii1, ij0, ij1          ! local integers 
    377       INTEGER  ::   inum0, icot                 !   -       - 
    378       REAL(wp) ::   zinfl, zlon                 ! local scalars 
    379       REAL(wp) ::   zlat, zlat0, zlat1, zlat2   !   -      - 
    380       REAL(wp) ::   zsdmp, zbdmp                !   -      - 
    381       CHARACTER(len=20)                   :: cfile 
    382       REAL(wp), POINTER, DIMENSION(:    ) :: zhfac  
    383       REAL(wp), POINTER, DIMENSION(:,:  ) :: zmrs  
    384       REAL(wp), POINTER, DIMENSION(:,:,:) :: zdct  
    385       !!---------------------------------------------------------------------- 
    386       ! 
    387       IF( nn_timing == 1 )  CALL timing_start('dtacof') 
    388       ! 
    389       CALL wrk_alloc( jpk, zhfac          ) 
    390       CALL wrk_alloc( jpi, jpj, zmrs      ) 
    391       CALL wrk_alloc( jpi, jpj, jpk, zdct ) 
    392 #if defined key_c1d 
    393       !                                   ! ==================== 
    394       !                                   !  C1D configuration : local domain 
    395       !                                   ! ==================== 
    396       ! 
    397       IF(lwp) WRITE(numout,*) 
    398       IF(lwp) WRITE(numout,*) '              dtacof : C1D 3x3 local domain' 
    399       IF(lwp) WRITE(numout,*) '              -----------------------------' 
    400       ! 
    401       presto(:,:,:) = 0._wp 
    402       ! 
    403       zsdmp = 1._wp / ( pn_surf * rday ) 
    404       zbdmp = 1._wp / ( pn_bot  * rday ) 
    405       DO jk = 2, jpkm1 
    406          DO jj = 1, jpj 
    407             DO ji = 1, jpi 
    408                !   ONLY vertical variation from zsdmp (sea surface) to zbdmp (bottom) 
    409                presto(ji,jj,jk) = zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(ji,jj,jk)/pn_dep) 
    410             END DO 
    411          END DO 
    412       END DO 
    413       ! 
    414       presto(:,:, : ) = presto(:,:,:) * tmask(:,:,:) 
    415 #else 
    416       !                                   ! ==================== 
    417       !                                   !  ORCA configuration : global domain 
    418       !                                   ! ==================== 
    419       ! 
    420       IF(lwp) WRITE(numout,*) 
    421       IF(lwp) WRITE(numout,*) '              dtacof : Global domain of ORCA' 
    422       IF(lwp) WRITE(numout,*) '              ------------------------------' 
    423       ! 
    424       presto(:,:,:) = 0._wp 
    425       ! 
    426       IF( kn_hdmp > 0 ) THEN      !  Damping poleward of 'nn_hdmp' degrees  ! 
    427          !                        !-----------------------------------------! 
    428          IF(lwp) WRITE(numout,*) 
    429          IF(lwp) WRITE(numout,*) '              Damping poleward of ', kn_hdmp, ' deg.' 
    430          ! 
    431          CALL iom_open ( 'dist.coast.nc', icot, ldstop = .FALSE. ) 
    432          ! 
    433          IF( icot > 0 ) THEN          ! distance-to-coast read in file 
    434             CALL iom_get  ( icot, jpdom_data, 'Tcoast', zdct ) 
    435             CALL iom_close( icot ) 
    436          ELSE                         ! distance-to-coast computed and saved in file (output in zdct) 
    437             CALL cofdis( zdct ) 
    438          ENDIF 
    439  
    440          !                            ! Compute arrays resto  
    441          zinfl = 1000.e3_wp                ! distance of influence for damping term 
    442          zlat0 = 10._wp                    ! latitude strip where resto decreases 
    443          zlat1 = REAL( kn_hdmp )           ! resto = 0 between -zlat1 and zlat1 
    444          zlat2 = zlat1 + zlat0             ! resto increases from 0 to 1 between |zlat1| and |zlat2| 
    445  
    446          DO jj = 1, jpj 
    447             DO ji = 1, jpi 
    448                zlat = ABS( gphit(ji,jj) ) 
    449                IF ( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN 
    450                   presto(ji,jj,1) = 0.5_wp * (  1._wp - COS( rpi*(zlat-zlat1)/zlat0 )  ) 
    451                ELSEIF ( zlat > zlat2 ) THEN 
    452                   presto(ji,jj,1) = 1._wp 
    453                ENDIF 
    454             END DO 
    455          END DO 
    456  
    457          IF ( kn_hdmp == 20 ) THEN       ! North Indian ocean (20N/30N x 45E/100E) : resto=0 
    458             DO jj = 1, jpj 
    459                DO ji = 1, jpi 
    460                   zlat = gphit(ji,jj) 
    461                   zlon = MOD( glamt(ji,jj), 360._wp ) 
    462                   IF ( zlat1 < zlat .AND. zlat < zlat2 .AND. 45._wp < zlon .AND. zlon < 100._wp ) THEN 
    463                      presto(ji,jj,1) = 0._wp 
    464                   ENDIF 
    465                END DO 
    466             END DO 
    467          ENDIF 
    468  
    469          zsdmp = 1._wp / ( pn_surf * rday ) 
    470          zbdmp = 1._wp / ( pn_bot  * rday ) 
    471          DO jk = 2, jpkm1 
    472             DO jj = 1, jpj 
    473                DO ji = 1, jpi 
    474                   zdct(ji,jj,jk) = MIN( zinfl, zdct(ji,jj,jk) ) 
    475                   !   ... Decrease the value in the vicinity of the coast 
    476                   presto(ji,jj,jk) = presto(ji,jj,1 ) * 0.5_wp * (  1._wp - COS( rpi*zdct(ji,jj,jk)/zinfl)  ) 
    477                   !   ... Vertical variation from zsdmp (sea surface) to zbdmp (bottom) 
    478                   presto(ji,jj,jk) = presto(ji,jj,jk) * (  zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(ji,jj,jk)/pn_dep)  ) 
    479                END DO 
    480             END DO 
    481          END DO 
    482          ! 
    483       ENDIF 
    484  
    485       !                                  ! ========================= 
    486       !                                  !  Med and Red Sea damping    (ORCA configuration only) 
    487       !                                  ! ========================= 
    488       IF( cp_cfg == "orca" .AND. ( kn_hdmp > 0 .OR. kn_hdmp == -1 ) ) THEN 
    489          IF(lwp)WRITE(numout,*) 
    490          IF(lwp)WRITE(numout,*) '              ORCA configuration: Damping in Med and Red Seas' 
    491          ! 
    492          zmrs(:,:) = 0._wp 
    493          ! 
    494          SELECT CASE ( jp_cfg ) 
    495          !                                           ! ======================= 
    496          CASE ( 4 )                                  !  ORCA_R4 configuration  
    497             !                                        ! ======================= 
    498             ij0 =  50   ;   ij1 =  56                    ! Mediterranean Sea 
    499  
    500             ii0 =  81   ;   ii1 =  91   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    501             ij0 =  50   ;   ij1 =  55 
    502             ii0 =  75   ;   ii1 =  80   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    503             ij0 =  52   ;   ij1 =  53 
    504             ii0 =  70   ;   ii1 =  74   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    505             ! Smooth transition from 0 at surface to 1./rday at the 18th level in Med and Red Sea 
    506             DO jk = 1, 17 
    507                zhfac (jk) = 0.5_wp * (  1._wp - COS( rpi * REAL(jk-1,wp) / 16._wp )  ) / rday 
    508             END DO 
    509             DO jk = 18, jpkm1 
    510                zhfac (jk) = 1._wp / rday 
    511             END DO 
    512             !                                        ! ======================= 
    513          CASE ( 2 )                                  !  ORCA_R2 configuration  
    514             !                                        ! ======================= 
    515             ij0 =  96   ;   ij1 = 110                    ! Mediterranean Sea 
    516             ii0 = 157   ;   ii1 = 181   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    517             ij0 = 100   ;   ij1 = 110 
    518             ii0 = 144   ;   ii1 = 156   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    519             ij0 = 100   ;   ij1 = 103 
    520             ii0 = 139   ;   ii1 = 143   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    521             ! 
    522             ij0 = 101   ;   ij1 = 102                    ! Decrease before Gibraltar Strait 
    523             ii0 = 139   ;   ii1 = 141   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0._wp 
    524             ii0 = 142   ;   ii1 = 142   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp 
    525             ii0 = 143   ;   ii1 = 143   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp 
    526             ii0 = 144   ;   ii1 = 144   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.75_wp 
    527             ! 
    528             ij0 =  87   ;   ij1 =  96                    ! Red Sea 
    529             ii0 = 147   ;   ii1 = 163   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    530             ! 
    531             ij0 =  91   ;   ij1 =  91                    ! Decrease before Bab el Mandeb Strait 
    532             ii0 = 153   ;   ii1 = 160   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.80_wp 
    533             ij0 =  90   ;   ij1 =  90 
    534             ii0 = 153   ;   ii1 = 160   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp 
    535             ij0 =  89   ;   ij1 =  89 
    536             ii0 = 158   ;   ii1 = 160   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp 
    537             ij0 =  88   ;   ij1 =  88 
    538             ii0 = 160   ;   ii1 = 163   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0._wp 
    539             ! Smooth transition from 0 at surface to 1./rday at the 18th level in Med and Red Sea 
    540             DO jk = 1, 17 
    541                zhfac (jk) = 0.5_wp * (  1._wp - COS( rpi * REAL(jk-1,wp) / 16._wp )  ) / rday 
    542             END DO 
    543             DO jk = 18, jpkm1 
    544                zhfac (jk) = 1._wp / rday 
    545             END DO 
    546             !                                        ! ======================= 
    547          CASE ( 05 )                                 !  ORCA_R05 configuration 
    548             !                                        ! ======================= 
    549             ii0 = 568   ;   ii1 = 574                    ! Mediterranean Sea 
    550             ij0 = 324   ;   ij1 = 333   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    551             ii0 = 575   ;   ii1 = 658 
    552             ij0 = 314   ;   ij1 = 366   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    553             ! 
    554             ii0 = 641   ;   ii1 = 651                    ! Black Sea (remaining part 
    555             ij0 = 367   ;   ij1 = 372   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    556             ! 
    557             ij0 = 324   ;   ij1 = 333                    ! Decrease before Gibraltar Strait 
    558             ii0 = 565   ;   ii1 = 565   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp 
    559             ii0 = 566   ;   ii1 = 566   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp 
    560             ii0 = 567   ;   ii1 = 567   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.75_wp 
    561             ! 
    562             ii0 = 641   ;   ii1 = 665                    ! Red Sea 
    563             ij0 = 270   ;   ij1 = 310   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    564             ! 
    565             ii0 = 666   ;   ii1 = 675                    ! Decrease before Bab el Mandeb Strait 
    566             ij0 = 270   ;   ij1 = 290    
    567             DO ji = mi0(ii0), mi1(ii1) 
    568                zmrs( ji , mj0(ij0):mj1(ij1) ) = 0.1_wp * ABS( FLOAT(ji - mi1(ii1)) ) 
    569             END DO  
    570             zsdmp = 1._wp / ( pn_surf * rday ) 
    571             zbdmp = 1._wp / ( pn_bot  * rday ) 
    572             DO jk = 1, jpk 
    573                zhfac(jk) = (  zbdmp + (zsdmp-zbdmp) * EXP( -fsdept(1,1,jk)/pn_dep )  ) 
    574             END DO 
    575             !                                       ! ======================== 
    576          CASE ( 025 )                               !  ORCA_R025 configuration  
    577             !                                       ! ======================== 
    578             CALL ctl_stop( ' Not yet implemented in ORCA_R025' ) 
    579             ! 
    580          END SELECT 
    581  
    582          DO jk = 1, jpkm1 
    583             presto(:,:,jk) = zmrs(:,:) * zhfac(jk) + ( 1._wp - zmrs(:,:) ) * presto(:,:,jk) 
    584          END DO 
    585  
    586          ! Mask resto array and set to 0 first and last levels 
    587          presto(:,:, : ) = presto(:,:,:) * tmask(:,:,:) 
    588          presto(:,:, 1 ) = 0._wp 
    589          presto(:,:,jpk) = 0._wp 
    590          !                         !--------------------! 
    591       ELSE                         !     No damping     ! 
    592          !                         !--------------------! 
    593          CALL ctl_stop( 'Choose a correct value of nn_hdmp or put ln_tradmp to FALSE' ) 
    594       ENDIF 
    595 #endif 
    596  
    597       !                            !--------------------------------! 
    598       IF( kn_file == 1 ) THEN      !  save damping coef. in a file  ! 
    599          !                         !--------------------------------! 
    600          IF(lwp) WRITE(numout,*) '              create damping.coeff.nc file' 
    601          IF( cdtype == 'TRA' ) cfile = 'damping.coeff' 
    602          IF( cdtype == 'TRC' ) cfile = 'damping.coeff.trc' 
    603          IF( cdtype == 'DYN' ) cfile = 'damping.coeff.dyn' 
    604          cfile = TRIM( cfile ) 
    605          CALL iom_open  ( cfile, inum0, ldwrt = .TRUE., kiolib = jprstlib ) 
    606          CALL iom_rstput( 0, 0, inum0, 'Resto', presto ) 
    607          CALL iom_close ( inum0 ) 
    608       ENDIF 
    609       ! 
    610       CALL wrk_dealloc( jpk, zhfac) 
    611       CALL wrk_dealloc( jpi, jpj, zmrs ) 
    612       CALL wrk_dealloc( jpi, jpj, jpk, zdct ) 
    613       ! 
    614       IF( nn_timing == 1 )  CALL timing_stop('dtacof') 
    615       ! 
    616    END SUBROUTINE dtacof 
    617  
    618  
    619    SUBROUTINE cofdis( pdct ) 
    620       !!---------------------------------------------------------------------- 
    621       !!                 ***  ROUTINE cofdis  *** 
    622       !! 
    623       !! ** Purpose :   Compute the distance between ocean T-points and the 
    624       !!      ocean model coastlines. Save the distance in a NetCDF file. 
    625       !! 
    626       !! ** Method  :   For each model level, the distance-to-coast is  
    627       !!      computed as follows :  
    628       !!       - The coastline is defined as the serie of U-,V-,F-points 
    629       !!      that are at the ocean-land bound. 
    630       !!       - For each ocean T-point, the distance-to-coast is then  
    631       !!      computed as the smallest distance (on the sphere) between the  
    632       !!      T-point and all the coastline points. 
    633       !!       - For land T-points, the distance-to-coast is set to zero. 
    634       !!      C A U T I O N : Computation not yet implemented in mpp case. 
    635       !! 
    636       !! ** Action  : - pdct, distance to the coastline (argument) 
    637       !!              - NetCDF file 'dist.coast.nc'  
    638       !!---------------------------------------------------------------------- 
    639       USE ioipsl      ! IOipsl librairy 
    640       !! 
    641       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out ) ::   pdct   ! distance to the coastline 
    642       !! 
    643       INTEGER ::   ji, jj, jk, jl   ! dummy loop indices 
    644       INTEGER ::   iju, ijt, icoast, itime, ierr, icot   ! local integers 
    645       CHARACTER (len=32) ::   clname                     ! local name 
    646       REAL(wp) ::   zdate0                               ! local scalar 
    647       REAL(wp), POINTER, DIMENSION(:,:) ::  zxt, zyt, zzt, zmask 
    648       REAL(wp), POINTER, DIMENSION(:  ) ::  zxc, zyc, zzc, zdis    ! temporary workspace 
    649       LOGICAL , ALLOCATABLE, DIMENSION(:,:) ::  llcotu, llcotv, llcotf   ! 2D logical workspace 
    650       !!---------------------------------------------------------------------- 
    651       ! 
    652       IF( nn_timing == 1 )  CALL timing_start('cofdis') 
    653       ! 
    654       CALL wrk_alloc( jpi, jpj , zxt, zyt, zzt, zmask    ) 
    655       CALL wrk_alloc( 3*jpi*jpj, zxc, zyc, zzc, zdis     ) 
    656       ALLOCATE( llcotu(jpi,jpj), llcotv(jpi,jpj), llcotf(jpi,jpj)  ) 
    657       ! 
    658       IF( lk_mpp    )   CALL mpp_sum( ierr ) 
    659       IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'cofdis: requested local arrays unavailable') 
    660  
    661       ! 0. Initialization 
    662       ! ----------------- 
    663       IF(lwp) WRITE(numout,*) 
    664       IF(lwp) WRITE(numout,*) 'cofdis : compute the distance to coastline' 
    665       IF(lwp) WRITE(numout,*) '~~~~~~' 
    666       IF(lwp) WRITE(numout,*) 
    667       IF( lk_mpp ) & 
    668            & CALL ctl_stop('         Computation not yet implemented with key_mpp_...', & 
    669            &               '         Rerun the code on another computer or ', & 
    670            &               '         create the "dist.coast.nc" file using IDL' ) 
    671  
    672       pdct(:,:,:) = 0._wp 
    673       zxt(:,:) = COS( rad * gphit(:,:) ) * COS( rad * glamt(:,:) ) 
    674       zyt(:,:) = COS( rad * gphit(:,:) ) * SIN( rad * glamt(:,:) ) 
    675       zzt(:,:) = SIN( rad * gphit(:,:) ) 
    676  
    677  
    678       ! 1. Loop on vertical levels 
    679       ! -------------------------- 
    680       !                                                ! =============== 
    681       DO jk = 1, jpkm1                                 ! Horizontal slab 
    682          !                                             ! =============== 
    683          ! Define the coastline points (U, V and F) 
    684          DO jj = 2, jpjm1 
    685             DO ji = 2, jpim1 
    686                zmask(ji,jj) =  ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 
    687                    &           + tmask(ji,jj  ,jk) + tmask(ji+1,jj  ,jk) ) 
    688                llcotu(ji,jj) = ( tmask(ji,jj,  jk) + tmask(ji+1,jj  ,jk) == 1._wp )  
    689                llcotv(ji,jj) = ( tmask(ji,jj  ,jk) + tmask(ji  ,jj+1,jk) == 1._wp )  
    690                llcotf(ji,jj) = ( zmask(ji,jj) > 0._wp ) .AND. ( zmask(ji,jj) < 4._wp ) 
    691             END DO 
    692          END DO 
    693  
    694          ! Lateral boundaries conditions 
    695          llcotu(:, 1 ) = umask(:,  2  ,jk) == 1 
    696          llcotu(:,jpj) = umask(:,jpjm1,jk) == 1 
    697          llcotv(:, 1 ) = vmask(:,  2  ,jk) == 1 
    698          llcotv(:,jpj) = vmask(:,jpjm1,jk) == 1 
    699          llcotf(:, 1 ) = fmask(:,  2  ,jk) == 1 
    700          llcotf(:,jpj) = fmask(:,jpjm1,jk) == 1 
    701  
    702          IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
    703             llcotu( 1 ,:) = llcotu(jpim1,:) 
    704             llcotu(jpi,:) = llcotu(  2  ,:) 
    705             llcotv( 1 ,:) = llcotv(jpim1,:) 
    706             llcotv(jpi,:) = llcotv(  2  ,:) 
    707             llcotf( 1 ,:) = llcotf(jpim1,:) 
    708             llcotf(jpi,:) = llcotf(  2  ,:) 
    709          ELSE 
    710             llcotu( 1 ,:) = umask(  2  ,:,jk) == 1 
    711             llcotu(jpi,:) = umask(jpim1,:,jk) == 1 
    712             llcotv( 1 ,:) = vmask(  2  ,:,jk) == 1 
    713             llcotv(jpi,:) = vmask(jpim1,:,jk) == 1 
    714             llcotf( 1 ,:) = fmask(  2  ,:,jk) == 1 
    715             llcotf(jpi,:) = fmask(jpim1,:,jk) == 1 
    716          ENDIF 
    717          IF( nperio == 3 .OR. nperio == 4 ) THEN 
    718             DO ji = 1, jpim1 
    719                iju = jpi - ji + 1 
    720                llcotu(ji,jpj  ) = llcotu(iju,jpj-2) 
    721                llcotf(ji,jpjm1) = llcotf(iju,jpj-2) 
    722                llcotf(ji,jpj  ) = llcotf(iju,jpj-3) 
    723             END DO 
    724             DO ji = jpi/2, jpim1 
    725                iju = jpi - ji + 1 
    726                llcotu(ji,jpjm1) = llcotu(iju,jpjm1) 
    727             END DO 
    728             DO ji = 2, jpi 
    729                ijt = jpi - ji + 2 
    730                llcotv(ji,jpjm1) = llcotv(ijt,jpj-2) 
    731                llcotv(ji,jpj  ) = llcotv(ijt,jpj-3) 
    732             END DO 
    733          ENDIF 
    734          IF( nperio == 5 .OR. nperio == 6 ) THEN 
    735             DO ji = 1, jpim1 
    736                iju = jpi - ji 
    737                llcotu(ji,jpj  ) = llcotu(iju,jpjm1) 
    738                llcotf(ji,jpj  ) = llcotf(iju,jpj-2) 
    739             END DO 
    740             DO ji = jpi/2, jpim1 
    741                iju = jpi - ji 
    742                llcotf(ji,jpjm1) = llcotf(iju,jpjm1) 
    743             END DO 
    744             DO ji = 1, jpi 
    745                ijt = jpi - ji + 1 
    746                llcotv(ji,jpj  ) = llcotv(ijt,jpjm1) 
    747             END DO 
    748             DO ji = jpi/2+1, jpi 
    749                ijt = jpi - ji + 1 
    750                llcotv(ji,jpjm1) = llcotv(ijt,jpjm1) 
    751             END DO 
    752          ENDIF 
    753  
    754          ! Compute cartesian coordinates of coastline points 
    755          ! and the number of coastline points 
    756          icoast = 0 
    757          DO jj = 1, jpj 
    758             DO ji = 1, jpi 
    759                IF( llcotf(ji,jj) ) THEN 
    760                   icoast = icoast + 1 
    761                   zxc(icoast) = COS( rad*gphif(ji,jj) ) * COS( rad*glamf(ji,jj) ) 
    762                   zyc(icoast) = COS( rad*gphif(ji,jj) ) * SIN( rad*glamf(ji,jj) ) 
    763                   zzc(icoast) = SIN( rad*gphif(ji,jj) ) 
    764                ENDIF 
    765                IF( llcotu(ji,jj) ) THEN 
    766                   icoast = icoast+1 
    767                   zxc(icoast) = COS( rad*gphiu(ji,jj) ) * COS( rad*glamu(ji,jj) ) 
    768                   zyc(icoast) = COS( rad*gphiu(ji,jj) ) * SIN( rad*glamu(ji,jj) ) 
    769                   zzc(icoast) = SIN( rad*gphiu(ji,jj) ) 
    770                ENDIF 
    771                IF( llcotv(ji,jj) ) THEN 
    772                   icoast = icoast+1 
    773                   zxc(icoast) = COS( rad*gphiv(ji,jj) ) * COS( rad*glamv(ji,jj) ) 
    774                   zyc(icoast) = COS( rad*gphiv(ji,jj) ) * SIN( rad*glamv(ji,jj) ) 
    775                   zzc(icoast) = SIN( rad*gphiv(ji,jj) ) 
    776                ENDIF 
    777             END DO 
    778          END DO 
    779  
    780          ! Distance for the T-points 
    781          DO jj = 1, jpj 
    782             DO ji = 1, jpi 
    783                IF( tmask(ji,jj,jk) == 0._wp ) THEN 
    784                   pdct(ji,jj,jk) = 0._wp 
    785                ELSE 
    786                   DO jl = 1, icoast 
    787                      zdis(jl) = ( zxt(ji,jj) - zxc(jl) )**2   & 
    788                         &     + ( zyt(ji,jj) - zyc(jl) )**2   & 
    789                         &     + ( zzt(ji,jj) - zzc(jl) )**2 
    790                   END DO 
    791                   pdct(ji,jj,jk) = ra * SQRT( MINVAL( zdis(1:icoast) ) ) 
    792                ENDIF 
    793             END DO 
    794          END DO 
    795          !                                                ! =============== 
    796       END DO                                              !   End of slab 
    797       !                                                   ! =============== 
    798  
    799  
    800       ! 2. Create the  distance to the coast file in NetCDF format 
    801       ! ----------------------------------------------------------     
    802       clname = 'dist.coast' 
    803       itime  = 0 
    804       CALL ymds2ju( 0     , 1       , 1     , 0._wp , zdate0 ) 
    805       CALL restini( 'NONE', jpi     , jpj   , glamt, gphit ,   & 
    806          &          jpk   , gdept_1d, clname, itime, zdate0,   & 
    807          &          rdt   , icot                         ) 
    808       CALL restput( icot, 'Tcoast', jpi, jpj, jpk, 0, pdct ) 
    809       CALL restclo( icot ) 
    810       ! 
    811       CALL wrk_dealloc( jpi, jpj , zxt, zyt, zzt, zmask    ) 
    812       CALL wrk_dealloc( 3*jpi*jpj, zxc, zyc, zzc, zdis     ) 
    813       DEALLOCATE( llcotu, llcotv, llcotf  ) 
    814       ! 
    815       IF( nn_timing == 1 )  CALL timing_stop('cofdis') 
    816       ! 
    817    END SUBROUTINE cofdis 
    818    !!====================================================================== 
    819249END MODULE tradmp 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

    r5038 r5620  
    290290      IF(lwp) WRITE(numout,*) '              homogeneous ocean T = ', zt0, ' S = ',zs0 
    291291 
     292      ! Initialisation of gtui/gtvi in case of no cavity 
     293      IF ( .NOT. ln_isfcav ) THEN 
     294         gtui(:,:,:) = 0.0_wp 
     295         gtvi(:,:,:) = 0.0_wp 
     296      END IF 
    292297      !                                        ! T & S profile (to be coded +namelist parameter 
    293298 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90

    r5038 r5620  
    116116               END DO 
    117117            END DO 
    118  
    119118            !                          !==  Laplacian  ==! 
    120119            ! 
     
    125124               END DO 
    126125            END DO 
     126            ! 
    127127            IF( ln_zps ) THEN                ! set gradient at partial step level (last ocean level) 
    128128               DO jj = 1, jpjm1 
     
    130130                     IF( mbku(ji,jj) == jk )  ztu(ji,jj,jk) = zeeu(ji,jj) * pgu(ji,jj,jn) 
    131131                     IF( mbkv(ji,jj) == jk )  ztv(ji,jj,jk) = zeev(ji,jj) * pgv(ji,jj,jn) 
    132                      ! (ISH) 
    133                      IF( miku(ji,jj) == jk )  ztu(ji,jj,jk) = zeeu(ji,jj) * pgui(ji,jj,jn) 
    134                      IF( mikv(ji,jj) == jk )  ztu(ji,jj,jk) = zeev(ji,jj) * pgvi(ji,jj,jn) 
    135132                  END DO 
    136133               END DO 
    137134            ENDIF 
     135            ! (ISH) 
     136            IF( ln_zps .AND. ln_isfcav ) THEN ! set gradient at partial step level (first ocean level in a cavity) 
     137               DO jj = 1, jpjm1 
     138                  DO ji = 1, jpim1 
     139                     IF( miku(ji,jj) == MAX(jk,2) )  ztu(ji,jj,jk) = zeeu(ji,jj) * pgui(ji,jj,jn) 
     140                     IF( mikv(ji,jj) == MAX(jk,2) )  ztu(ji,jj,jk) = zeev(ji,jj) * pgvi(ji,jj,jn) 
     141                  END DO 
     142               END DO 
     143            ENDIF 
     144            ! 
    138145            DO jj = 2, jpjm1                 ! Second derivative (divergence) time the eddy diffusivity coefficient 
    139146               DO ji = fs_2, fs_jpim1   ! vector opt. 
     
    166173         !                                                 
    167174         ! "zonal" mean lateral diffusive heat and salt transport 
    168          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    169            IF( jn == jp_tem )  htr_ldf(:) = ptr_vj( ztv(:,:,:) ) 
    170            IF( jn == jp_sal )  str_ldf(:) = ptr_vj( ztv(:,:,:) ) 
     175         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     176           IF( jn == jp_tem )  htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 
     177           IF( jn == jp_sal )  str_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    171178         ENDIF 
    172179         !                                                ! =========== 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90

    r4292 r5620  
    247247         !                                                ! =============== 
    248248         ! "Poleward" diffusive heat or salt transport 
    249          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
     249         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) ) THEN 
    250250            ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    251             IF( jn == jp_tem)   htr_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
    252             IF( jn == jp_sal)   str_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
     251            IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
     252            IF( jn == jp_sal)   str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    253253         ENDIF 
    254254 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90

    r5038 r5620  
    2828   USE in_out_manager  ! I/O manager 
    2929   USE iom             ! I/O library 
    30 #if defined key_diaar5 
    3130   USE phycst          ! physical constants 
    3231   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    33 #endif 
    3432   USE wrk_nemo        ! Memory Allocation 
    3533   USE timing          ! Timing 
     
    106104      ! 
    107105      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
     106      INTEGER  ::  ikt 
    108107      REAL(wp) ::  zmsku, zabe1, zcof1, zcoef3   ! local scalars 
    109108      REAL(wp) ::  zmskv, zabe2, zcof2, zcoef4   !   -      - 
    110109      REAL(wp) ::  zcoef0, zbtr, ztra            !   -      - 
    111 #if defined key_diaar5 
    112       REAL(wp)                         ::   zztmp               ! local scalar 
    113 #endif 
    114110      REAL(wp), POINTER, DIMENSION(:,:  ) ::  z2d 
    115111      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zdkt, zdk1t, zdit, zdjt, ztfw  
     
    149145            END DO 
    150146         END DO 
     147 
     148         ! partial cell correction 
    151149         IF( ln_zps ) THEN      ! partial steps correction at the last ocean level  
    152150            DO jj = 1, jpjm1 
    153151               DO ji = 1, fs_jpim1   ! vector opt. 
    154152! IF useless if zpshde defines pgu everywhere 
    155                   IF (mbku(ji,jj) > 1) zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
    156                   IF (mbkv(ji,jj) > 1) zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    157                   ! (ISF) 
     153                  zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
     154                  zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
     155               END DO 
     156            END DO 
     157         ENDIF 
     158         IF( ln_zps .AND. ln_isfcav ) THEN      ! partial steps correction at the first wet level beneath a cavity 
     159            DO jj = 1, jpjm1 
     160               DO ji = 1, fs_jpim1   ! vector opt. 
    158161                  IF (miku(ji,jj) > 1) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)           
    159162                  IF (mikv(ji,jj) > 1) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)      
    160163               END DO 
    161164            END DO 
    162          ENDIF 
     165         END IF 
    163166 
    164167         !!---------------------------------------------------------------------- 
    165168         !!   II - horizontal trend  (full) 
    166169         !!---------------------------------------------------------------------- 
    167 !CDIR PARALLEL DO PRIVATE( zdk1t )  
    168          !                                                ! =============== 
    169          DO jj = 1, jpj                                 ! Horizontal slab 
    170             !                                             ! =============== 
    171             DO ji = 1, jpi   ! vector opt. 
    172                DO jk = mikt(ji,jj), jpkm1 
    173                ! 1. Vertical tracer gradient at level jk and jk+1 
    174                ! ------------------------------------------------ 
    175                ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 
    176                   zdk1t(ji,jj,jk) = ( ptb(ji,jj,jk,jn) - ptb(ji,jj,jk+1,jn) ) * tmask(ji,jj,jk+1) 
    177                ! 
    178                   IF( jk == mikt(ji,jj) ) THEN  ;   zdkt(ji,jj,jk) = zdk1t(ji,jj,jk) 
    179                   ELSE                          ;   zdkt(ji,jj,jk) = ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    180                   ENDIF 
     170!!!!!!!!!!CDIR PARALLEL DO PRIVATE( zdk1t )  
     171            ! 1. Vertical tracer gradient at level jk and jk+1 
     172            ! ------------------------------------------------ 
     173         !  
     174         ! interior value  
     175         DO jk = 2, jpkm1                
     176            DO jj = 1, jpj 
     177               DO ji = 1, jpi   ! vector opt. 
     178                  zdk1t(ji,jj,jk) = ( ptb(ji,jj,jk,jn  ) - ptb(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1) 
     179                  ! 
     180                  zdkt(ji,jj,jk)  = ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn  ) ) * wmask(ji,jj,jk) 
    181181               END DO 
    182182            END DO 
    183183         END DO 
    184  
    185             ! 2. Horizontal fluxes 
    186             ! --------------------    
    187          DO jj = 1 , jpjm1 
    188             DO ji = 1, fs_jpim1   ! vector opt. 
    189                DO jk = mikt(ji,jj), jpkm1 
     184         ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 
     185         zdk1t(:,:,1) = ( ptb(:,:,1,jn  ) - ptb(:,:,2,jn) ) * wmask(:,:,2) 
     186         zdkt (:,:,1) = zdk1t(:,:,1) 
     187         IF ( ln_isfcav ) THEN 
     188            DO jj = 1, jpj 
     189               DO ji = 1, jpi   ! vector opt. 
     190                  ikt = mikt(ji,jj) ! surface level 
     191                  zdk1t(ji,jj,ikt) = ( ptb(ji,jj,ikt,jn  ) - ptb(ji,jj,ikt+1,jn) ) * wmask(ji,jj,ikt+1) 
     192                  zdkt (ji,jj,ikt) = zdk1t(ji,jj,ikt) 
     193               END DO 
     194            END DO 
     195         END IF 
     196 
     197         ! 2. Horizontal fluxes 
     198         ! --------------------    
     199         DO jk = 1, jpkm1 
     200            DO jj = 1 , jpjm1 
     201               DO ji = 1, fs_jpim1   ! vector opt. 
    190202                  zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
    191203                  zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
     
    208220               END DO 
    209221            END DO 
    210          END DO 
    211222 
    212223            ! II.4 Second derivative (divergence) and add to the general trend 
    213224            ! ---------------------------------------------------------------- 
    214          DO jj = 2 , jpjm1 
    215             DO ji = fs_2, fs_jpim1   ! vector opt. 
    216                DO jk = mikt(ji,jj), jpkm1 
    217                   zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     225            DO jj = 2 , jpjm1 
     226               DO ji = fs_2, fs_jpim1   ! vector opt. 
     227                  zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    218228                  ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  ) 
    219229                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
     
    225235         ! 
    226236         ! "Poleward" diffusive heat or salt transports (T-S case only) 
    227          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
     237         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    228238            ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    229             IF( jn == jp_tem)   htr_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
    230             IF( jn == jp_sal)   str_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
     239            IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
     240            IF( jn == jp_sal)   str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    231241         ENDIF 
    232242  
    233 #if defined key_diaar5 
    234          IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
    235             z2d(:,:) = 0._wp  
    236             ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    237             zztmp = -1.0_wp * rau0 * rcp 
    238             DO jk = 1, jpkm1 
    239                DO jj = 2, jpjm1 
    240                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    241                      z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
     243         IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 
     244           ! 
     245           IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
     246               z2d(:,:) = 0._wp  
     247               DO jk = 1, jpkm1 
     248                  DO jj = 2, jpjm1 
     249                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     250                        z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
     251                     END DO 
    242252                  END DO 
    243253               END DO 
    244             END DO 
    245             z2d(:,:) = zztmp * z2d(:,:) 
    246             CALL lbc_lnk( z2d, 'U', -1. ) 
    247             CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
    248             z2d(:,:) = 0._wp  
    249             DO jk = 1, jpkm1 
    250                DO jj = 2, jpjm1 
    251                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    252                      z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
     254               z2d(:,:) = - rau0_rcp * z2d(:,:)     ! note sign is reversed to give down-gradient diffusive transports (#1043) 
     255               CALL lbc_lnk( z2d, 'U', -1. ) 
     256               CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
     257               ! 
     258               z2d(:,:) = 0._wp  
     259               DO jk = 1, jpkm1 
     260                  DO jj = 2, jpjm1 
     261                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     262                        z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
     263                     END DO 
    253264                  END DO 
    254265               END DO 
    255             END DO 
    256             z2d(:,:) = zztmp * z2d(:,:) 
    257             CALL lbc_lnk( z2d, 'V', -1. ) 
    258             CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
    259          END IF 
    260 #endif 
     266               z2d(:,:) = - rau0_rcp * z2d(:,:)     ! note sign is reversed to give down-gradient diffusive transports (#1043) 
     267               CALL lbc_lnk( z2d, 'V', -1. ) 
     268               CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
     269            END IF 
     270            ! 
     271         ENDIF 
    261272 
    262273         !!---------------------------------------------------------------------- 
     
    278289            DO jj = 2, jpjm1 
    279290               DO ji = fs_2, fs_jpim1   ! vector opt. 
    280                   zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 
     291                  zcoef0 = - fsahtw(ji,jj,jk) * wmask(ji,jj,jk) 
    281292                  ! 
    282293                  zmsku = 1./MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)      & 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90

    r5038 r5620  
    113113      REAL(wp) ::   ze1ur, zdxt, ze2vr, ze3wr, zdyt, zdzt 
    114114      REAL(wp) ::   zah, zah_slp, zaei_slp 
    115 #if defined key_diaar5 
    116       REAL(wp) ::   zztmp              ! local scalar 
    117 #endif 
    118115      REAL(wp), POINTER, DIMENSION(:,:  ) :: z2d 
    119116      REAL(wp), POINTER, DIMENSION(:,:,:) :: zdit, zdjt, ztfw  
     
    207204      END DO 
    208205      ! 
    209 #if defined key_iomput 
    210       IF( ln_traldf_gdia .AND. cdtype == 'TRA' ) THEN 
    211          CALL wrk_alloc( jpi , jpj , jpk  , zw3d ) 
    212          DO jk=1,jpkm1 
    213             zw3d(:,:,jk) = (psix_eiv(:,:,jk+1) - psix_eiv(:,:,jk))/fse3u(:,:,jk)  ! u_eiv = -dpsix/dz 
    214          END DO 
    215          zw3d(:,:,jpk) = 0._wp 
    216          CALL iom_put( "uoce_eiv", zw3d )    ! i-eiv current 
    217  
    218          DO jk=1,jpk-1 
    219             zw3d(:,:,jk) = (psiy_eiv(:,:,jk+1) - psiy_eiv(:,:,jk))/fse3v(:,:,jk)  ! v_eiv = -dpsiy/dz 
    220          END DO 
    221          zw3d(:,:,jpk) = 0._wp 
    222          CALL iom_put( "voce_eiv", zw3d )    ! j-eiv current 
    223  
    224          DO jk=1,jpk-1 
    225             DO jj = 2, jpjm1 
    226                DO ji = fs_2, fs_jpim1  ! vector opt. 
    227                   zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2t(ji,jj) + & 
    228                        &    (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1t(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 
    229                END DO 
    230             END DO 
    231          END DO 
    232          zw3d(:,:,jpk) = 0._wp 
    233          CALL iom_put( "woce_eiv", zw3d )    ! vert. eiv current 
    234          CALL wrk_dealloc( jpi , jpj , jpk  , zw3d ) 
     206      IF( iom_use("uoce_eiv") .OR. iom_use("voce_eiv") .OR. iom_use("woce_eiv") )  THEN 
     207         ! 
     208         IF( ln_traldf_gdia .AND. cdtype == 'TRA' ) THEN 
     209            CALL wrk_alloc( jpi , jpj , jpk  , zw3d ) 
     210            DO jk=1,jpkm1 
     211               zw3d(:,:,jk) = (psix_eiv(:,:,jk+1) - psix_eiv(:,:,jk))/fse3u(:,:,jk)  ! u_eiv = -dpsix/dz 
     212            END DO 
     213            zw3d(:,:,jpk) = 0._wp 
     214            CALL iom_put( "uoce_eiv", zw3d )    ! i-eiv current 
     215 
     216            DO jk=1,jpk-1 
     217               zw3d(:,:,jk) = (psiy_eiv(:,:,jk+1) - psiy_eiv(:,:,jk))/fse3v(:,:,jk)  ! v_eiv = -dpsiy/dz 
     218            END DO 
     219            zw3d(:,:,jpk) = 0._wp 
     220            CALL iom_put( "voce_eiv", zw3d )    ! j-eiv current 
     221 
     222            DO jk=1,jpk-1 
     223               DO jj = 2, jpjm1 
     224                  DO ji = fs_2, fs_jpim1  ! vector opt. 
     225                     zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2t(ji,jj) + & 
     226                          &    (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1t(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 
     227                  END DO 
     228               END DO 
     229            END DO 
     230            zw3d(:,:,jpk) = 0._wp 
     231            CALL iom_put( "woce_eiv", zw3d )    ! vert. eiv current 
     232            CALL wrk_dealloc( jpi , jpj , jpk  , zw3d ) 
     233         ENDIF 
     234         ! 
    235235      ENDIF 
    236 #endif 
    237236      !                                                          ! =========== 
    238237      DO jn = 1, kjpt                                            ! tracer loop 
     
    387386         ! 
    388387         !                             ! "Poleward" diffusive heat or salt transports (T-S case only) 
    389          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
    390             IF( jn == jp_tem)   htr_ldf(:) = ptr_vj( zftv(:,:,:) )        ! 3.3  names 
    391             IF( jn == jp_sal)   str_ldf(:) = ptr_vj( zftv(:,:,:) ) 
     388         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
     389            IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( zftv(:,:,:) )        ! 3.3  names 
     390            IF( jn == jp_sal)   str_ldf(:) = ptr_sj( zftv(:,:,:) ) 
    392391         ENDIF 
    393392 
    394 #if defined key_diaar5 
    395          IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
    396             z2d(:,:) = 0._wp 
    397             zztmp = rau0 * rcp 
    398             DO jk = 1, jpkm1 
    399                DO jj = 2, jpjm1 
    400                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    401                      z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk) 
    402                   END DO 
    403                END DO 
    404             END DO 
    405             z2d(:,:) = zztmp * z2d(:,:) 
    406             CALL lbc_lnk( z2d, 'U', -1. ) 
    407             CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
    408             z2d(:,:) = 0._wp 
    409             DO jk = 1, jpkm1 
    410                DO jj = 2, jpjm1 
    411                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    412                      z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk) 
    413                   END DO 
    414                END DO 
    415             END DO 
    416             z2d(:,:) = zztmp * z2d(:,:) 
    417             CALL lbc_lnk( z2d, 'V', -1. ) 
    418             CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in j-direction 
    419          END IF 
    420 #endif 
     393         IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 
     394           ! 
     395           IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
     396               z2d(:,:) = 0._wp  
     397               DO jk = 1, jpkm1 
     398                  DO jj = 2, jpjm1 
     399                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     400                        z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
     401                     END DO 
     402                  END DO 
     403               END DO 
     404               z2d(:,:) = rau0_rcp * z2d(:,:)  
     405               CALL lbc_lnk( z2d, 'U', -1. ) 
     406               CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
     407               ! 
     408               z2d(:,:) = 0._wp  
     409               DO jk = 1, jpkm1 
     410                  DO jj = 2, jpjm1 
     411                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     412                        z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
     413                     END DO 
     414                  END DO 
     415               END DO 
     416               z2d(:,:) = rau0_rcp * z2d(:,:)      
     417               CALL lbc_lnk( z2d, 'V', -1. ) 
     418               CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
     419            END IF 
     420            ! 
     421         ENDIF 
    421422         ! 
    422423      END DO 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90

    r5038 r5620  
    102102               END DO 
    103103            END DO 
    104             IF( ln_zps ) THEN      ! set gradient at partial step level 
     104            IF( ln_zps ) THEN      ! set gradient at partial step level for the last ocean cell 
    105105               DO jj = 1, jpjm1 
    106106                  DO ji = 1, fs_jpim1   ! vector opt. 
     
    116116                        ztv(ji,jj,jk) = zabe2 * pgv(ji,jj,jn) 
    117117                     ENDIF 
    118                       
    119                      ! (ISH) 
     118                  END DO 
     119               END DO 
     120            ENDIF 
     121            ! (ISH) 
     122            IF( ln_zps .AND. ln_isfcav ) THEN      ! set gradient at partial step level for the first ocean cell 
     123                                                   ! into a cavity 
     124               DO jj = 1, jpjm1 
     125                  DO ji = 1, fs_jpim1   ! vector opt. 
    120126                     ! ice shelf level level MAX(2,jk) => only where ice shelf 
    121127                     iku = miku(ji,jj)  
     
    148154         ! 
    149155         ! "Poleward" diffusive heat or salt transports 
    150          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
    151             IF( jn  == jp_tem)   htr_ldf(:) = ptr_vj( ztv(:,:,:) ) 
    152             IF( jn  == jp_sal)   str_ldf(:) = ptr_vj( ztv(:,:,:) ) 
     156         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
     157            IF( jn  == jp_tem)   htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 
     158            IF( jn  == jp_sal)   str_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    153159         ENDIF 
    154160         !                                                  ! ================== 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/tranpc.F90

    r5038 r5620  
    99   !!            3.0  ! 2008-06  (G. Madec)  applied on ta, sa and called before tranxt in step.F90 
    1010   !!            3.3  ! 2010-05  (C. Ethe, G. Madec)  merge TRC-TRA 
    11    !!            3.7  ! 2014-06  (L. Brodeau) new algorithm based on local Brunt-Vaisala freq. 
     11   !!            3.6  ! 2015-05  (L. Brodeau) new algorithm based on local Brunt-Vaisala freq. 
    1212   !!---------------------------------------------------------------------- 
    1313 
     
    6464      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    6565      INTEGER  ::   inpcc        ! number of statically instable water column 
    66       INTEGER  ::   jiter, ikbot, ik, ikup, ikdown, ilayer, ikm   ! local integers 
     66      INTEGER  ::   jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low   ! local integers 
    6767      LOGICAL  ::   l_bottom_reached, l_column_treated 
    6868      REAL(wp) ::   zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z 
    6969      REAL(wp) ::   zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_r2dt 
     70      REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp       ! acceptance criteria for neutrality (N2==0) 
    7071      REAL(wp), POINTER, DIMENSION(:)       ::   zvn2   ! vertical profile of N2 at 1 given point... 
    7172      REAL(wp), POINTER, DIMENSION(:,:)     ::   zvts   ! vertical profile of T and S at 1 given point... 
     
    7576      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   ztrdt, ztrds   ! 3D workspace 
    7677      ! 
    77       !!LB debug: 
    78       LOGICAL, PARAMETER :: l_LB_debug = .FALSE. 
    79       INTEGER :: ilc1, jlc1, klc1, nncpu 
    80       LOGICAL :: lp_monitor_point = .FALSE. 
    81       !!LB debug. 
     78      LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is 
     79      INTEGER :: ilc1, jlc1, klc1, nncpu         ! actually happening in a water column at point "ilc1, jlc1" 
     80      LOGICAL :: lp_monitor_point = .FALSE.      ! in CPU domain "nncpu" 
    8281      !!---------------------------------------------------------------------- 
    8382      ! 
     
    9796         ENDIF 
    9897 
    99          !LB debug: 
    100          IF( lwp .AND. l_LB_debug ) THEN 
    101             WRITE(numout,*) 
    102             WRITE(numout,*) 'LOLO: entering tra_npc, kt, narea =', kt, narea 
    103          ENDIF 
    104          !LBdebug: Monitoring of 1 column subject to convection... 
    10598         IF( l_LB_debug ) THEN 
    106             ! Location of 1 known convection spot to follow what's happening in the water column 
    107             ilc1 = 54 ;  jlc1 = 15 ; ! Labrador ORCA1 4x4 cpus: 
    108             nncpu = 15  ; ! the CPU domain contains the convection spot 
    109             !ilc1 = 14 ;  jlc1 = 13 ; ! Labrador ORCA1 8x8 cpus: 
    110             !nncpu = 54  ; ! the CPU domain contains the convection spot 
     99            ! Location of 1 known convection site to follow what's happening in the water column 
     100            ilc1 = 45 ;  jlc1 = 3 ; !  ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the  water column...            
     101            nncpu = 1  ;            ! the CPU domain contains the convection spot 
    111102            klc1 =  mbkt(ilc1,jlc1) ! bottom of the ocean for debug point...           
    112103         ENDIF 
    113          !LBdebug. 
    114  
    115          CALL eos_rab( tsa, zab )         ! after alpha and beta 
    116          CALL bn2    ( tsa, zab, zn2 )    ! after Brunt-Vaisala 
     104          
     105         CALL eos_rab( tsa, zab )         ! after alpha and beta (given on T-points) 
     106         CALL bn2    ( tsa, zab, zn2 )    ! after Brunt-Vaisala  (given on W-points) 
    117107         
    118108         inpcc = 0 
     
    134124                     IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 
    135125                     ! writing only if on CPU domain where conv region is: 
    136                      lp_monitor_point = (narea == nncpu).AND.lp_monitor_point  
    137                       
    138                      IF(lp_monitor_point) THEN 
    139                         WRITE(numout,*) '' ;WRITE(numout,*) '' ; 
    140                        WRITE(numout,'("Time step = ",i6.6," !!!")')  kt 
    141                         WRITE(numout,'(" *** BEFORE anything, N^2 for point ",i3,",",i3,":" )') ji,jj 
    142                         DO jk = 1, klc1 
    143                            WRITE(numout,*) jk, zvn2(jk) 
    144                         END DO 
    145                         WRITE(numout,*) ' ' 
    146                      ENDIF 
     126                     lp_monitor_point = (narea == nncpu).AND.lp_monitor_point                       
    147127                  ENDIF                                  !LB debug  end 
    148128 
    149129                  ikbot = mbkt(ji,jj)   ! ikbot: ocean bottom T-level 
    150                   ik = 1                ! because N2 is irrelevant at the surface level (will start at ik=2) 
     130                  ikp = 1                  ! because N2 is irrelevant at the surface level (will start at ikp=2) 
    151131                  ilayer = 0 
    152132                  jiter  = 0 
     
    163143                     DO WHILE ( .NOT. l_bottom_reached ) 
    164144 
    165                         ik = ik + 1 
     145                        ikp = ikp + 1 
    166146                        
    167                         !! Checking level ik for instability 
     147                        !! Testing level ikp for instability 
    168148                        !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    169  
    170                         IF( zvn2(ik) < 0. ) THEN ! Instability found! 
    171  
    172                            ikm  = ik              ! first level whith negative N2 
    173                            ilayer = ilayer + 1    ! yet another layer found.... 
    174                            IF(jiter == 1) inpcc = inpcc + 1 
    175  
    176                            IF(l_LB_debug .AND. lp_monitor_point) & 
    177                               & WRITE(numout,*) 'Negative N2 at ik =', ikm, ' layer nb.', ilayer, & 
    178                               & ' inpcc =', inpcc 
    179  
    180                            !! Case we mix with upper regions where N2==0: 
    181                            !! All the points above ikup where N2 == 0 must also be mixed => we go 
    182                            !! upward to find a new ikup, where the layer doesn't have N2==0 
    183                            ikup = ikm 
    184                            DO jk = ikm, 2, -1 
    185                               ikup = ikup - 1 
    186                               IF( (zvn2(jk-1) > 0.).OR.(ikup == 1) ) EXIT 
    187                            END DO 
    188                            
    189                            ! adjusting ikup if the upper part of the unstable column was neutral (N2=0) 
    190                            IF((zvn2(ikup+1) == 0.).AND.(ikup /= 1)) ikup = ikup+1 ; 
    191  
    192                            
    193                            IF( lp_monitor_point )   WRITE(numout,*) ' => ikup is =', ikup, ' layer nb.', ilayer 
    194                            
     149                        IF( zvn2(ikp) <  -zn2_zero ) THEN ! Instability found! 
     150 
     151                           ilayer = ilayer + 1    ! yet another instable portion of the water column found.... 
     152 
     153                           IF( lp_monitor_point ) THEN  
     154                              WRITE(numout,*) 
     155                              IF( ilayer == 1 .AND. jiter == 1 ) THEN   ! first time a column is spoted with an instability 
     156                                 WRITE(numout,*) 
     157                                 WRITE(numout,*) 'Time step = ',kt,' !!!' 
     158                              ENDIF 
     159                              WRITE(numout,*)  ' * Iteration #',jiter,': found instable portion #',ilayer,   & 
     160                                 &                                    ' in column! Starting at ikp =', ikp 
     161                              WRITE(numout,*)  ' *** N2 for point (i,j) = ',ji,' , ',jj 
     162                              DO jk = 1, klc1 
     163                                 WRITE(numout,*) jk, zvn2(jk) 
     164                              END DO 
     165                              WRITE(numout,*) 
     166                           ENDIF 
     167                            
     168 
     169                           IF( jiter == 1 )   inpcc = inpcc + 1  
     170 
     171                           IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
     172 
     173                           !! ikup is the uppermost point where mixing will start: 
     174                           ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying 
     175                            
     176                           !! If the points above ikp-1 have N2 == 0 they must also be mixed: 
     177                           IF( ikp > 2 ) THEN 
     178                              DO jk = ikp-1, 2, -1 
     179                                 IF( ABS(zvn2(jk)) < zn2_zero ) THEN 
     180                                    ikup = ikup - 1  ! 1 more upper level has N2=0 and must be added for the mixing 
     181                                 ELSE 
     182                                    EXIT 
     183                                 ENDIF 
     184                              END DO 
     185                           ENDIF 
     186                            
     187                           IF( ikup < 1 )   CALL ctl_stop( 'tra_npc :  PROBLEM #1') 
     188 
    195189                           zsum_temp = 0._wp 
    196190                           zsum_sali = 0._wp 
     
    199193                           zsum_z    = 0._wp 
    200194                                                     
    201                            DO jk = ikup, ikbot+1      ! Inside the instable (and overlying neutral) portion of the column 
    202                               ! 
    203                               IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) '     -> summing for jk =', jk 
     195                           DO jk = ikup, ikbot      ! Inside the instable (and overlying neutral) portion of the column 
    204196                              ! 
    205197                              zdz       = fse3t(ji,jj,jk) 
     
    209201                              zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 
    210202                              zsum_z    = zsum_z    + zdz 
    211                               ! 
    212                               !! EXIT if we found the bottom of the unstable portion of the water column     
    213                               IF( (zvn2(jk+1) > 0.).OR.(jk == ikbot ).OR.((jk==ikm).AND.(zvn2(jk+1) == 0.)) )   EXIT 
     203                              !                               
     204                              IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line 
     205                              !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): 
     206                              IF( zvn2(jk+1) > zn2_zero ) EXIT 
    214207                           END DO 
    215208                           
    216                            !ik     = jk !LB remove? 
    217                            ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative N2 
    218                            
    219                            IF(l_LB_debug .AND. lp_monitor_point) & 
    220                               &    WRITE(numout,*) '  => ikdown =', ikdown, '  layer nb.', ilayer 
    221                            
    222                            ! Mixing Temperature and salinity between ikup and ikdown: 
     209                           ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 
     210                           IF( ikup == ikdown )   CALL ctl_stop( 'tra_npc :  PROBLEM #2') 
     211 
     212                           ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included: 
    223213                           zta   = zsum_temp/zsum_z 
    224214                           zsa   = zsum_sali/zsum_z 
     
    226216                           zbeta = zsum_beta/zsum_z 
    227217 
    228                            IF(l_LB_debug .AND. lp_monitor_point) THEN 
     218                           IF( lp_monitor_point ) THEN 
     219                              WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup,   & 
     220                                 &            ' and ikdown =',ikdown,', in layer #',ilayer 
    229221                              WRITE(numout,*) '  => Mean temp. in that portion =', zta 
    230222                              WRITE(numout,*) '  => Mean sali. in that portion =', zsa 
    231                               WRITE(numout,*) '  => Mean Alpha in that portion =', zalfa 
     223                              WRITE(numout,*) '  => Mean Alfa in that portion =', zalfa 
    232224                              WRITE(numout,*) '  => Mean Beta  in that portion =', zbeta 
    233225                           ENDIF 
     
    240232                              zvab(jk,jp_sal) = zbeta 
    241233                           END DO 
    242                            ! 
    243                            !! Before updating N2, it is possible that another unstable 
    244                            !! layer exists underneath the one we just homogeneized! 
    245                            ik = ikdown 
    246                            !  
    247                         ENDIF  ! IF( zvn2(ik+1) < 0. ) THEN 
    248                         ! 
    249                         IF( ik == ikbot ) l_bottom_reached = .TRUE. 
     234                            
     235                            
     236                           !! Updating N2 in the relvant portion of the water column 
     237                           !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 
     238                           !! => Need to re-compute N2! will use Alpha and Beta! 
     239                            
     240                           ikup   = MAX(2,ikup)         ! ikup can never be 1 ! 
     241                           ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! 
     242                            
     243                           DO jk = ikup, ik_low              ! we must go 1 point deeper than ikdown! 
     244 
     245                              !! Interpolating alfa and beta at W point: 
     246                              zrw =  (fsdepw(ji,jj,jk  ) - fsdept(ji,jj,jk)) & 
     247                                 & / (fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk)) 
     248                              zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 
     249                              zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 
     250 
     251                              !! N2 at W point, doing exactly as in eosbn2.F90: 
     252                              zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
     253                                 &            - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  & 
     254                                 &       / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 
     255 
     256                              !! OR, faster  => just considering the vertical gradient of density 
     257                              !! as only the signa maters... 
     258                              !zvn2(jk) = (  zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
     259                              !     &      - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  ) 
     260 
     261                           END DO 
     262                         
     263                           ikp = MIN(ikdown+1,ikbot) 
     264                            
     265 
     266                        ENDIF  !IF( zvn2(ikp) < 0. ) 
     267 
     268 
     269                        IF( ikp == ikbot ) l_bottom_reached = .TRUE. 
    250270                        ! 
    251271                     END DO ! DO WHILE ( .NOT. l_bottom_reached ) 
    252272 
    253                      IF( ik /= ikbot )   STOP 'ERROR: tranpc.F90 => PROBLEM #1' 
     273                     IF( ikp /= ikbot )   CALL ctl_stop( 'tra_npc :  PROBLEM #3') 
    254274                     
    255                      ! ******* At this stage ik == ikbot ! ******* 
     275                     ! ******* At this stage ikp == ikbot ! ******* 
    256276                     
    257                      IF( ilayer > 0 ) THEN 
    258                         !! least an unstable layer has been found 
    259                         !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 
    260                         !! => Need to re-compute N2! will use Alpha and Beta! 
     277                     IF( ilayer > 0 ) THEN      !! least an unstable layer has been found 
    261278                        ! 
    262                         DO jk = ikup+1, ikdown+1   ! we must go 1 point deeper than ikdown!      
    263                            !! Doing exactly as in eosbn2.F90: 
    264                            !! * Except that we only are interested in the sign of N2 !!! 
    265                            !!   => just considering the vertical gradient of density 
    266                            zrw =   (fsdepw(ji,jj,jk  ) - fsdept(ji,jj,jk)) & 
    267                                & / (fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk)) 
    268                            zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 
    269                            zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 
    270                            
    271                            !zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
    272                            !     &           - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  & 
    273                            !     &       / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 
    274                            zvn2(jk) = (  zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
    275                                 &      - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )   
    276                         END DO 
    277  
    278                         IF(l_LB_debug .AND. lp_monitor_point) THEN 
    279                            WRITE(numout, '(" *** After iteration #",i3.3,", N^2 for point ",i3,",",i3,":" )') & 
    280                               & jiter, ji,jj 
     279                        IF( lp_monitor_point ) THEN 
     280                           WRITE(numout,*) 
     281                           WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)' 
     282                           WRITE(numout,*) '   ==> N2 at i,j=',ji,',',jj,' now looks like this:' 
    281283                           DO jk = 1, klc1 
    282284                              WRITE(numout,*) jk, zvn2(jk) 
    283285                           END DO 
    284                            WRITE(numout,*) ' ' 
     286                           WRITE(numout,*) 
    285287                        ENDIF 
    286  
    287                         ik     = 1  ! starting again at the surface for the next iteration 
     288                        ! 
     289                        ikp    = 1     ! starting again at the surface for the next iteration 
    288290                        ilayer = 0 
    289291                     ENDIF 
    290292                     ! 
    291                      IF( ik >= ikbot ) THEN 
    292                         IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) '    --- exiting jiter loop ---' 
    293                         l_column_treated = .TRUE. 
    294                      ENDIF 
     293                     IF( ikp >= ikbot )   l_column_treated = .TRUE. 
    295294                     ! 
    296295                  END DO ! DO WHILE ( .NOT. l_column_treated ) 
     
    300299                  tsa(ji,jj,:,jp_sal) = zvts(:,jp_sal) 
    301300 
    302                   !! lolo:  Should we update something else???? 
    303                   !! => like alpha and beta? 
    304  
    305                   IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) '' 
     301                  !! LB:  Potentially some other global variable beside theta and S can be treated here 
     302                  !!      like BGC tracers. 
     303 
     304                  IF( lp_monitor_point )   WRITE(numout,*) 
    306305 
    307306               ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN 
     
    321320         CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. )   ;   CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 
    322321         ! 
    323          IF(lwp) THEN 
    324             WRITE(numout,*) 'LOLO: exiting tra_npc, kt =', kt 
    325             WRITE(numout,*)' => number of statically instable water column : ',inpcc 
    326             WRITE(numout,*) '' ; WRITE(numout,*) '' 
     322         IF( lwp .AND. l_LB_debug ) THEN 
     323            WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', inpcc 
     324            WRITE(numout,*) 
    327325         ENDIF 
    328326         ! 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r5038 r5620  
    2727   USE dom_oce         ! ocean space and time domain variables  
    2828   USE sbc_oce         ! surface boundary condition: ocean 
     29   USE sbcrnf          ! river runoffs 
    2930   USE zdf_oce         ! ocean vertical mixing 
    3031   USE domvvl          ! variable volume 
     
    143144      ELSE                                            ! Leap-Frog + Asselin filter time stepping 
    144145         ! 
    145          IF( lk_vvl )  THEN   ;   CALL tra_nxt_vvl( kt, nit000, 'TRA', tsb, tsn, tsa, jpts )  ! variable volume level (vvl)      
    146          ELSE                 ;   CALL tra_nxt_fix( kt, nit000, 'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
     146         IF( lk_vvl )  THEN   ;   CALL tra_nxt_vvl( kt, nit000, rdttra, 'TRA', tsb, tsn, tsa,   & 
     147           &                                                              sbc_tsc, sbc_tsc_b, jpts )  ! variable volume level (vvl)  
     148         ELSE                 ;   CALL tra_nxt_fix( kt, nit000,         'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
    147149         ENDIF 
    148150      ENDIF  
     
    241243 
    242244 
    243    SUBROUTINE tra_nxt_vvl( kt, kit000, cdtype, ptb, ptn, pta, kjpt ) 
     245   SUBROUTINE tra_nxt_vvl( kt, kit000, p2dt, cdtype, ptb, ptn, pta, psbc_tc, psbc_tc_b, kjpt ) 
    244246      !!---------------------------------------------------------------------- 
    245247      !!                   ***  ROUTINE tra_nxt_vvl  *** 
     
    265267      !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
    266268      !!---------------------------------------------------------------------- 
    267       INTEGER         , INTENT(in   )                               ::   kt       ! ocean time-step index 
    268       INTEGER         , INTENT(in   )                               ::   kit000   ! first time step index 
    269       CHARACTER(len=3), INTENT(in   )                               ::   cdtype   ! =TRA or TRC (tracer indicator) 
    270       INTEGER         , INTENT(in   )                               ::   kjpt     ! number of tracers 
    271       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptb      ! before tracer fields 
    272       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptn      ! now tracer fields 
    273       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   pta      ! tracer trend 
     269      INTEGER         , INTENT(in   )                               ::  kt       ! ocean time-step index 
     270      INTEGER         , INTENT(in   )                               ::  kit000   ! first time step index 
     271      REAL(wp)        , INTENT(in   ), DIMENSION(jpk)               ::  p2dt     ! time-step 
     272      CHARACTER(len=3), INTENT(in   )                               ::  cdtype   ! =TRA or TRC (tracer indicator) 
     273      INTEGER         , INTENT(in   )                               ::  kjpt     ! number of tracers 
     274      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptb      ! before tracer fields 
     275      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptn      ! now tracer fields 
     276      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  pta      ! tracer trend 
     277      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt)      ::  psbc_tc   ! surface tracer content 
     278      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt)      ::  psbc_tc_b ! before surface tracer content 
     279 
    274280      !!      
    275       LOGICAL  ::   ll_tra, ll_tra_hpg, ll_traqsr   ! local logical 
     281      LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf   ! local logical 
    276282      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    277283      REAL(wp) ::   zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
     
    286292      ! 
    287293      IF( cdtype == 'TRA' )  THEN    
    288          ll_tra     = .TRUE.           ! active tracers case   
    289294         ll_tra_hpg = ln_dynhpg_imp    ! active  tracers case  and  semi-implicit hpg 
    290295         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
     296         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
    291297      ELSE                           
    292          ll_tra     = .FALSE.          ! passive tracers case 
    293298         ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
    294299         ll_traqsr  = .FALSE.          ! active  tracers case and NO solar penetration 
     300         ll_rnf     = .FALSE.          ! passive tracers or NO river runoffs 
    295301      ENDIF 
    296302      ! 
    297303      DO jn = 1, kjpt       
    298304         DO jk = 1, jpkm1 
    299             zfact1 = atfp * rdttra(jk) 
     305            zfact1 = atfp * p2dt(jk) 
    300306            zfact2 = zfact1 / rau0 
    301307            DO jj = 1, jpj 
     
    315321                  ztc_f  = ztc_n  + atfp * ztc_d 
    316322                  ! 
    317                   IF( ll_tra .AND. jk == 1 ) THEN           ! first level only for T & S 
    318                       ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) ) 
    319                       ztc_f  = ztc_f  - zfact1 * ( sbc_tsc(ji,jj,jn) - sbc_tsc_b(ji,jj,jn) ) 
     323                  IF( jk == 1 ) THEN           ! first level  
     324                     ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) + rnf(ji,jj) - rnf_b(ji,jj) ) 
     325                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    320326                  ENDIF 
     327 
    321328                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )   &     ! solar penetration (temperature only) 
    322329                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
    323330 
    324                    ze3t_f = 1.e0 / ze3t_f 
    325                    ptb(ji,jj,jk,jn) = ztc_f * ze3t_f       ! ptb <-- ptn filtered 
    326                    ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)     ! ptn <-- pta 
    327                    ! 
    328                    IF( ll_tra_hpg ) THEN        ! semi-implicit hpg (T & S only) 
    329                       ze3t_d           = 1.e0   / ( ze3t_n + rbcp * ze3t_d ) 
    330                       pta(ji,jj,jk,jn) = ze3t_d * ( ztc_n  + rbcp * ztc_d  )   ! ta <-- Brown & Campana average 
    331                    ENDIF 
     331                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )   &            ! river runoffs 
     332                     &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
     333                     &                              * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 
     334 
     335                  ze3t_f = 1.e0 / ze3t_f 
     336                  ptb(ji,jj,jk,jn) = ztc_f * ze3t_f       ! ptb <-- ptn filtered 
     337                  ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)     ! ptn <-- pta 
     338                  ! 
     339                  IF( ll_tra_hpg ) THEN        ! semi-implicit hpg (T & S only) 
     340                     ze3t_d           = 1.e0   / ( ze3t_n + rbcp * ze3t_d ) 
     341                     pta(ji,jj,jk,jn) = ze3t_d * ( ztc_n  + rbcp * ztc_d  )   ! ta <-- Brown & Campana average 
     342                  ENDIF 
    332343               END DO 
    333344            END DO 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r5038 r5620  
    3232   USE wrk_nemo       ! Memory Allocation 
    3333   USE timing         ! Timing 
    34    USE sbc_ice, ONLY : lk_lim3 
    3534 
    3635   IMPLICIT NONE 
     
    3837 
    3938   PUBLIC   tra_qsr       ! routine called by step.F90 (ln_traqsr=T) 
    40    PUBLIC   tra_qsr_init  ! routine called by opa.F90 
     39   PUBLIC   tra_qsr_init  ! routine called by nemogcm.F90 
    4140 
    4241   !                                 !!* Namelist namtra_qsr: penetrative solar radiation 
     
    5049   REAL(wp), PUBLIC ::   rn_si0       !: very near surface depth of extinction      (RGB & 2 bands) 
    5150   REAL(wp), PUBLIC ::   rn_si1       !: deepest depth of extinction (water type I)       (2 bands) 
    52     
     51  
    5352   ! Module variables 
    5453   REAL(wp) ::   xsi0r                           !: inverse of rn_si0 
     
    165164         CALL iom_put( 'qsr3d', etot3 )   ! Shortwave Radiation 3D distribution 
    166165         ! clem: store attenuation coefficient of the first ocean level 
    167          IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     166         IF ( ln_qsr_ice ) THEN 
    168167            DO jj = 1, jpj 
    169168               DO ji = 1, jpi 
    170169                  IF ( qsr(ji,jj) /= 0._wp ) THEN 
    171170                     fraqsr_1lev(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 
     171                  ELSE 
     172                     fraqsr_1lev(ji,jj) = 1. 
    172173                  ENDIF 
    173174               END DO 
     
    233234               END DO 
    234235               ! clem: store attenuation coefficient of the first ocean level 
    235                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     236               IF ( ln_qsr_ice ) THEN 
    236237                  DO jj = 1, jpj 
    237238                     DO ji = 1, jpi 
     
    256257               END DO 
    257258               ! clem: store attenuation coefficient of the first ocean level 
    258                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     259               IF ( ln_qsr_ice ) THEN 
    259260                  fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    260261               ENDIF 
     
    279280               END DO 
    280281               ! clem: store attenuation coefficient of the first ocean level 
    281                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     282               IF ( ln_qsr_ice ) THEN 
    282283                  DO jj = 1, jpj 
    283284                     DO ji = 1, jpi 
     
    298299               END DO 
    299300               ! clem: store attenuation coefficient of the first ocean level 
    300                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     301               IF ( ln_qsr_ice ) THEN 
    301302                  fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    302303               ENDIF 
     
    324325            &                    'at it= ', kt,' date= ', ndastp 
    325326         IF(lwp) WRITE(numout,*) '~~~~' 
    326          CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b', qsr_hc ) 
     327         CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b'   , qsr_hc      ) 
     328         CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev )   ! default definition in sbcssm  
    327329         ! 
    328330      ENDIF 
     
    379381      ! 
    380382      IF( nn_timing == 1 )  CALL timing_start('tra_qsr_init') 
    381       ! 
    382       ! Default value for fraqsr_1lev 
    383       IF( .NOT. ln_rstart ) THEN 
    384          fraqsr_1lev(:,:) = 1._wp 
    385       ENDIF 
    386383      ! 
    387384      CALL wrk_alloc( jpi, jpj,      zekb, zekg, zekr        )  
     
    412409         WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0 = ', rn_si0 
    413410         WRITE(numout,*) '      2 bands: longest depth of extinction         rn_si1 = ', rn_si1 
    414          WRITE(numout,*) '      light penetration for ice-model LIM3     ln_qsr_ice = ', ln_qsr_ice     
    415411      ENDIF 
    416412 
     
    564560      ENDIF 
    565561      ! 
     562      ! initialisation of fraqsr_1lev used in sbcssm 
     563      IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 
     564         CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev'  , fraqsr_1lev  ) 
     565      ELSE 
     566         fraqsr_1lev(:,:) = 1._wp   ! default definition 
     567      ENDIF 
     568      ! 
    566569      CALL wrk_dealloc( jpi, jpj,      zekb, zekg, zekr        )  
    567570      CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r5038 r5620  
    99   !!            3.3  !  2010-04  (M. Leclair, G. Madec)  Forcing averaged over 2 time steps 
    1010   !!             -   !  2010-09  (C. Ethe, G. Madec) Merge TRA-TRC 
     11   !!            3.6  !  2014-11  (P. Mathiot) isf melting forcing  
    1112   !!---------------------------------------------------------------------- 
    1213 
     
    2021   USE sbcmod          ! ln_rnf   
    2122   USE sbcrnf          ! River runoff   
     23   USE sbcisf          ! Ice shelf    
    2224   USE traqsr          ! solar radiation penetration 
    2325   USE trd_oce         ! trends: ocean variables 
     
    2628   USE in_out_manager  ! I/O manager 
    2729   USE prtctl          ! Print control 
    28    USE sbcrnf          ! River runoff   
    29    USE sbcisf          ! Ice shelf    
    30    USE sbcmod          ! ln_rnf   
    3130   USE iom 
    3231   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90

    r5038 r5620  
    8888         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    8989      END SELECT 
     90      ! DRAKKAR SSS control { 
     91      ! JMM avoid negative salinities near river outlet ! Ugly fix 
     92      ! JMM : restore negative salinities to small salinities: 
     93      WHERE ( tsa(:,:,:,jp_sal) < 0._wp )   tsa(:,:,:,jp_sal) = 0.1_wp 
    9094 
    9195      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp.F90

    r5038 r5620  
    122122            DO jj=1, jpj 
    123123               DO ji=1, jpi 
    124                   zwt(ji,jj,1:mikt(ji,jj)) = 0._wp 
     124                  zwt(ji,jj,1) = 0._wp 
    125125               END DO 
    126126            END DO 
     
    184184            DO jj = 2, jpjm1 
    185185               DO ji = fs_2, fs_jpim1 
    186                   zwt(ji,jj,1:mikt(ji,jj)) = zwd(ji,jj,1:mikt(ji,jj)) 
    187                   DO jk = mikt(ji,jj)+1, jpkm1 
     186                  zwt(ji,jj,1) = zwd(ji,jj,1) 
     187               END DO 
     188            END DO 
     189            DO jk = 2, jpkm1 
     190               DO jj = 2, jpjm1 
     191                  DO ji = fs_2, fs_jpim1 
    188192                     zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 
    189193                  END DO 
     
    196200         DO jj = 2, jpjm1 
    197201            DO ji = fs_2, fs_jpim1 
    198                ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,mikt(ji,jj)) 
    199                ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,mikt(ji,jj)) 
    200                pta(ji,jj,mikt(ji,jj),jn) = ze3tb * ptb(ji,jj,mikt(ji,jj),jn)                     & 
    201                   &                      + p2dt(mikt(ji,jj)) * ze3tn * pta(ji,jj,mikt(ji,jj),jn) 
    202                DO jk = mikt(ji,jj)+1, jpkm1 
     202               ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,1) 
     203               ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,1) 
     204               pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn)                     & 
     205                  &                      + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 
     206            END DO 
     207         END DO 
     208         DO jk = 2, jpkm1 
     209            DO jj = 2, jpjm1 
     210               DO ji = fs_2, fs_jpim1 
    203211                  ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,jk) 
    204212                  ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t  (ji,jj,jk) 
     
    213221            DO ji = fs_2, fs_jpim1 
    214222               pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
    215                DO jk = jpk-2, mikt(ji,jj), -1 
     223            END DO 
     224         END DO 
     225         DO jk = jpk-2, 1, -1 
     226            DO jj = 2, jpjm1 
     227               DO ji = fs_2, fs_jpim1 
    216228                  pta(ji,jj,jk,jn) = ( pta(ji,jj,jk,jn) - zws(ji,jj,jk) * pta(ji,jj,jk+1,jn) )   & 
    217229                     &             / zwt(ji,jj,jk) * tmask(ji,jj,jk) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde.F90

    r5038 r5620  
    88   !!             -   !  2004-03  (C. Ethe)  adapted for passive tracers 
    99   !!            3.3  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA  
     10   !!            3.6  !  2014-11  (P. Mathiot) Add zps_hde_isf (needed to open a cavity) 
    1011   !!====================================================================== 
    1112    
     
    2728   PRIVATE 
    2829 
    29    PUBLIC   zps_hde    ! routine called by step.F90 
     30   PUBLIC   zps_hde     ! routine called by step.F90 
     31   PUBLIC   zps_hde_isf ! routine called by step.F90 
    3032 
    3133   !! * Substitutions 
     
    4042 
    4143   SUBROUTINE zps_hde( kt, kjpt, pta, pgtu, pgtv,   & 
     44      &                          prd, pgru, pgrv    ) 
     45      !!---------------------------------------------------------------------- 
     46      !!                     ***  ROUTINE zps_hde  *** 
     47      !!                     
     48      !! ** Purpose :   Compute the horizontal derivative of T, S and rho 
     49      !!      at u- and v-points with a linear interpolation for z-coordinate 
     50      !!      with partial steps. 
     51      !! 
     52      !! ** Method  :   In z-coord with partial steps, scale factors on last  
     53      !!      levels are different for each grid point, so that T, S and rd  
     54      !!      points are not at the same depth as in z-coord. To have horizontal 
     55      !!      gradients again, we interpolate T and S at the good depth :  
     56      !!      Linear interpolation of T, S    
     57      !!         Computation of di(tb) and dj(tb) by vertical interpolation: 
     58      !!          di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~ 
     59      !!          dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~ 
     60      !!         This formulation computes the two cases: 
     61      !!                 CASE 1                   CASE 2   
     62      !!         k-1  ___ ___________   k-1   ___ ___________ 
     63      !!                    Ti  T~                  T~  Ti+1 
     64      !!                  _____                        _____ 
     65      !!         k        |   |Ti+1     k           Ti |   | 
     66      !!                  |   |____                ____|   | 
     67      !!              ___ |   |   |           ___  |   |   | 
     68      !!                   
     69      !!      case 1->   e3w(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then 
     70      !!          t~ = t(i+1,j  ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1) 
     71      !!        ( t~ = t(i  ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1)  ) 
     72      !!          or 
     73      !!      case 2->   e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then 
     74      !!          t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i ) 
     75      !!        ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) ) 
     76      !!          Idem for di(s) and dj(s)           
     77      !! 
     78      !!      For rho, we call eos which will compute rd~(t~,s~) at the right 
     79      !!      depth zh from interpolated T and S for the different formulations 
     80      !!      of the equation of state (eos). 
     81      !!      Gradient formulation for rho : 
     82      !!          di(rho) = rd~ - rd(i,j,k)   or   rd(i+1,j,k) - rd~ 
     83      !! 
     84      !! ** Action  : compute for top interfaces 
     85      !!              - pgtu, pgtv: horizontal gradient of tracer at u- & v-points 
     86      !!              - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points 
     87      !!---------------------------------------------------------------------- 
     88      INTEGER                              , INTENT(in   )           ::  kt          ! ocean time-step index 
     89      INTEGER                              , INTENT(in   )           ::  kjpt        ! number of tracers 
     90      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta         ! 4D tracers fields 
     91      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts  
     92      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd         ! 3D density anomaly fields 
     93      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv  ! hor. grad of prd at u- & v-pts (bottom) 
     94      ! 
     95      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
     96      INTEGER  ::   iku, ikv, ikum1, ikvm1   ! partial step level (ocean bottom level) at u- and v-points 
     97      REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv  ! temporary scalars 
     98      REAL(wp), DIMENSION(jpi,jpj)      ::  zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
     99      REAL(wp), DIMENSION(jpi,jpj,kjpt) ::  zti, ztj             !  
     100      !!---------------------------------------------------------------------- 
     101      ! 
     102      IF( nn_timing == 1 )  CALL timing_start( 'zps_hde') 
     103      ! 
     104      pgtu(:,:,:)=0.0_wp ; pgtv(:,:,:)=0.0_wp ; 
     105      zti (:,:,:)=0.0_wp ; ztj (:,:,:)=0.0_wp ; 
     106      zhi (:,:  )=0.0_wp ; zhj (:,:  )=0.0_wp ; 
     107      ! 
     108      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
     109         ! 
     110         DO jj = 1, jpjm1 
     111            DO ji = 1, jpim1 
     112               iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
     113               ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
     114               ze3wu = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
     115               ze3wv = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
     116               ! 
     117               ! i- direction 
     118               IF( ze3wu >= 0._wp ) THEN      ! case 1 
     119                  zmaxu =  ze3wu / fse3w(ji+1,jj,iku) 
     120                  ! interpolated values of tracers 
     121                  zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     122                  ! gradient of  tracers 
     123                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     124               ELSE                           ! case 2 
     125                  zmaxu = -ze3wu / fse3w(ji,jj,iku) 
     126                  ! interpolated values of tracers 
     127                  zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
     128                  ! gradient of tracers 
     129                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     130               ENDIF 
     131               ! 
     132               ! j- direction 
     133               IF( ze3wv >= 0._wp ) THEN      ! case 1 
     134                  zmaxv =  ze3wv / fse3w(ji,jj+1,ikv) 
     135                  ! interpolated values of tracers 
     136                  ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
     137                  ! gradient of tracers 
     138                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     139               ELSE                           ! case 2 
     140                  zmaxv =  -ze3wv / fse3w(ji,jj,ikv) 
     141                  ! interpolated values of tracers 
     142                  ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
     143                  ! gradient of tracers 
     144                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     145               ENDIF 
     146            END DO 
     147         END DO 
     148         CALL lbc_lnk( pgtu(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
     149         ! 
     150      END DO 
     151 
     152      ! horizontal derivative of density anomalies (rd) 
     153      IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
     154         pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
     155         DO jj = 1, jpjm1 
     156            DO ji = 1, jpim1 
     157               iku = mbku(ji,jj) 
     158               ikv = mbkv(ji,jj) 
     159               ze3wu  = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
     160               ze3wv  = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
     161               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = fsdept(ji  ,jj,iku)     ! i-direction: case 1 
     162               ELSE                        ;   zhi(ji,jj) = fsdept(ji+1,jj,iku)     ! -     -      case 2 
     163               ENDIF 
     164               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = fsdept(ji,jj  ,ikv)     ! j-direction: case 1 
     165               ELSE                        ;   zhj(ji,jj) = fsdept(ji,jj+1,ikv)     ! -     -      case 2 
     166               ENDIF 
     167            END DO 
     168         END DO 
     169 
     170         ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 
     171         ! step and store it in  zri, zrj for each  case 
     172         CALL eos( zti, zhi, zri )   
     173         CALL eos( ztj, zhj, zrj ) 
     174 
     175         ! Gradient of density at the last level  
     176         DO jj = 1, jpjm1 
     177            DO ji = 1, jpim1 
     178               iku = mbku(ji,jj) 
     179               ikv = mbkv(ji,jj) 
     180               ze3wu  = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
     181               ze3wv  = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
     182               IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
     183               ELSE                        ;   pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
     184               ENDIF 
     185               IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
     186               ELSE                        ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
     187               ENDIF 
     188            END DO 
     189         END DO 
     190         CALL lbc_lnk( pgru , 'U', -1. )   ;   CALL lbc_lnk( pgrv , 'V', -1. )   ! Lateral boundary conditions 
     191         ! 
     192      END IF 
     193      ! 
     194      IF( nn_timing == 1 )  CALL timing_stop( 'zps_hde') 
     195      ! 
     196   END SUBROUTINE zps_hde 
     197   ! 
     198   SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv,   & 
    42199      &                          prd, pgru, pgrv, pmru, pmrv, pgzu, pgzv, pge3ru, pge3rv,  & 
    43       &                   sgtu, sgtv, sgru, sgrv, smru, smrv, sgzu, sgzv, sge3ru, sge3rv ) 
     200      &                   pgtui, pgtvi, pgrui, pgrvi, pmrui, pmrvi, pgzui, pgzvi, pge3rui, pge3rvi ) 
    44201      !!---------------------------------------------------------------------- 
    45202      !!                     ***  ROUTINE zps_hde  *** 
     
    82239      !! 
    83240      !! ** Action  : compute for top and bottom interfaces 
    84       !!              - pgtu, pgtv, sgtu, sgtv: horizontal gradient of tracer at u- & v-points 
    85       !!              - pgru, pgrv, sgru, sgtv: horizontal gradient of rho (if present) at u- & v-points 
    86       !!              - pmru, pmrv, smru, smrv: horizontal sum of rho at u- & v- point (used in dynhpg with vvl) 
    87       !!              - pgzu, pgzv, sgzu, sgzv: horizontal gradient of z at u- and v- point (used in dynhpg with vvl) 
    88       !!              - pge3ru, pge3rv, sge3ru, sge3rv: horizontal gradient of rho weighted by local e3w at u- & v-points  
     241      !!              - pgtu, pgtv, pgtui, pgtvi: horizontal gradient of tracer at u- & v-points 
     242      !!              - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points 
     243      !!              - pmru, pmrv, pmrui, pmrvi: horizontal sum of rho at u- & v- point (used in dynhpg with vvl) 
     244      !!              - pgzu, pgzv, pgzui, pgzvi: horizontal gradient of z at u- and v- point (used in dynhpg with vvl) 
     245      !!              - pge3ru, pge3rv, pge3rui, pge3rvi: horizontal gradient of rho weighted by local e3w at u- & v-points  
    89246      !!---------------------------------------------------------------------- 
    90247      INTEGER                              , INTENT(in   )           ::  kt          ! ocean time-step index 
     
    92249      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta         ! 4D tracers fields 
    93250      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts  
    94       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  sgtu, sgtv  ! hor. grad. of stra at u- & v-pts (ISF) 
     251      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtui, pgtvi  ! hor. grad. of stra at u- & v-pts (ISF) 
    95252      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd         ! 3D density anomaly fields 
    96253      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv      ! hor. grad of prd at u- & v-pts (bottom) 
     
    98255      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgzu, pgzv      ! hor. grad of z   at u- & v-pts (bottom) 
    99256      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pge3ru, pge3rv  ! hor. grad of prd weighted by local e3w at u- & v-pts (bottom) 
    100       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  sgru, sgrv      ! hor. grad of prd at u- & v-pts (top) 
    101       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  smru, smrv      ! hor. sum  of prd at u- & v-pts (top) 
    102       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  sgzu, sgzv      ! hor. grad of z   at u- & v-pts (top) 
    103       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  sge3ru, sge3rv  ! hor. grad of prd weighted by local e3w at u- & v-pts (top) 
     257      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgrui, pgrvi      ! hor. grad of prd at u- & v-pts (top) 
     258      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pmrui, pmrvi      ! hor. sum  of prd at u- & v-pts (top) 
     259      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgzui, pgzvi      ! hor. grad of z   at u- & v-pts (top) 
     260      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pge3rui, pge3rvi  ! hor. grad of prd weighted by local e3w at u- & v-pts (top) 
    104261      ! 
    105262      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
     
    110267      !!---------------------------------------------------------------------- 
    111268      ! 
    112       IF( nn_timing == 1 )  CALL timing_start( 'zps_hde') 
     269      IF( nn_timing == 1 )  CALL timing_start( 'zps_hde_isf') 
    113270      ! 
    114271      pgtu(:,:,:)=0.0_wp ; pgtv(:,:,:)=0.0_wp ; 
    115       sgtu(:,:,:)=0.0_wp ; sgtv(:,:,:)=0.0_wp ; 
     272      pgtui(:,:,:)=0.0_wp ; pgtvi(:,:,:)=0.0_wp ; 
    116273      zti (:,:,:)=0.0_wp ; ztj (:,:,:)=0.0_wp ; 
    117274      zhi (:,:  )=0.0_wp ; zhj (:,:  )=0.0_wp ; 
     
    256413                  zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,iku+1,jn) - pta(ji+1,jj,iku,jn) ) 
    257414                  ! gradient of tracers 
    258                   sgtu(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     415                  pgtui(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    259416               ELSE                           ! case 2 
    260417                  zmaxu = - ze3wu / fse3w(ji,jj,iku+1) 
     
    262419                  zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,iku+1,jn) - pta(ji,jj,iku,jn) ) 
    263420                  ! gradient of  tracers 
    264                   sgtu(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     421                  pgtui(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    265422               ENDIF 
    266423               ! 
     
    271428                  ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikv+1,jn) - pta(ji,jj+1,ikv,jn) ) 
    272429                  ! gradient of tracers 
    273                   sgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     430                  pgtvi(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    274431               ELSE                           ! case 2 
    275432                  zmaxv =  - ze3wv / fse3w(ji,jj,ikv+1) 
     
    277434                  ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikv+1,jn) - pta(ji,jj,ikv,jn) ) 
    278435                  ! gradient of tracers 
    279                   sgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     436                  pgtvi(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    280437               ENDIF 
    281438            END DO!! 
    282439         END DO!! 
    283          CALL lbc_lnk( sgtu(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( sgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
     440         CALL lbc_lnk( pgtui(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtvi(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
    284441         ! 
    285442      END DO 
     
    287444      ! horizontal derivative of density anomalies (rd) 
    288445      IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
    289          sgru(:,:)  =0.0_wp ; sgrv(:,:)  =0.0_wp ; 
    290          sgzu(:,:)  =0.0_wp ; sgzv(:,:)  =0.0_wp ; 
    291          smru(:,:)  =0.0_wp ; smru(:,:)  =0.0_wp ; 
    292          sge3ru(:,:)=0.0_wp ; sge3rv(:,:)=0.0_wp ; 
     446         pgrui(:,:)  =0.0_wp ; pgrvi(:,:)  =0.0_wp ; 
     447         pgzui(:,:)  =0.0_wp ; pgzvi(:,:)  =0.0_wp ; 
     448         pmrui(:,:)  =0.0_wp ; pmrui(:,:)  =0.0_wp ; 
     449         pge3rui(:,:)=0.0_wp ; pge3rvi(:,:)=0.0_wp ; 
    293450 
    294451         DO jj = 1, jpjm1 
     
    321478               ze3wv  = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 
    322479               IF( ze3wu >= 0._wp ) THEN 
    323                  sgzu  (ji,jj) = (fsde3w(ji+1,jj,iku) + ze3wu) - fsde3w(ji,jj,iku) 
    324                  sgru  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) - prd(ji,jj,iku) )          ! i: 1 
    325                  smru  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) + prd(ji,jj,iku) )          ! i: 1  
    326                  sge3ru(ji,jj) = umask(ji,jj,iku+1)                                                                  & 
     480                 pgzui  (ji,jj) = (fsde3w(ji+1,jj,iku) + ze3wu) - fsde3w(ji,jj,iku) 
     481                 pgrui  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) - prd(ji,jj,iku) )          ! i: 1 
     482                 pmrui  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) + prd(ji,jj,iku) )          ! i: 1  
     483                 pge3rui(ji,jj) = umask(ji,jj,iku+1)                                                                  & 
    327484                                * ( (fse3w(ji+1,jj,iku+1) - ze3wu) * (zri(ji,jj    ) + prd(ji+1,jj,iku+1) + 2._wp)   & 
    328485                                   - fse3w(ji  ,jj,iku+1)          * (prd(ji,jj,iku) + prd(ji  ,jj,iku+1) + 2._wp)   ) ! i: 1 
    329486               ELSE 
    330                  sgzu  (ji,jj) = fsde3w(ji+1,jj,iku) - (fsde3w(ji,jj,iku) - ze3wu) 
    331                  sgru  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) - zri(ji,jj) )      ! i: 2 
    332                  smru  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) + zri(ji,jj) )      ! i: 2 
    333                  sge3ru(ji,jj) = umask(ji,jj,iku+1)                                                                   & 
     487                 pgzui  (ji,jj) = fsde3w(ji+1,jj,iku) - (fsde3w(ji,jj,iku) - ze3wu) 
     488                 pgrui  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) - zri(ji,jj) )      ! i: 2 
     489                 pmrui  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) + zri(ji,jj) )      ! i: 2 
     490                 pge3rui(ji,jj) = umask(ji,jj,iku+1)                                                                   & 
    334491                                * (  fse3w(ji+1,jj,iku+1)          * (prd(ji+1,jj,iku) + prd(ji+1,jj,iku+1) + 2._wp)  & 
    335492                                   -(fse3w(ji  ,jj,iku+1) + ze3wu) * (zri(ji,jj      ) + prd(ji  ,jj,iku+1) + 2._wp)  )     ! i: 2 
    336493               ENDIF 
    337494               IF( ze3wv >= 0._wp ) THEN 
    338                  sgzv  (ji,jj) = (fsde3w(ji,jj+1,ikv) + ze3wv) - fsde3w(ji,jj,ikv)  
    339                  sgrv  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) - prd(ji,jj,ikv) )        ! j: 1 
    340                  smrv  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) + prd(ji,jj,ikv) )        ! j: 1 
    341                  sge3rv(ji,jj) = vmask(ji,jj,ikv+1)                                                                  &  
     495                 pgzvi  (ji,jj) = (fsde3w(ji,jj+1,ikv) + ze3wv) - fsde3w(ji,jj,ikv)  
     496                 pgrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) - prd(ji,jj,ikv) )        ! j: 1 
     497                 pmrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) + prd(ji,jj,ikv) )        ! j: 1 
     498                 pge3rvi(ji,jj) = vmask(ji,jj,ikv+1)                                                                  &  
    342499                                * ( (fse3w(ji,jj+1,ikv+1) - ze3wv) * ( zrj(ji,jj    ) + prd(ji,jj+1,ikv+1) + 2._wp)  & 
    343500                                   - fse3w(ji,jj  ,ikv+1)          * ( prd(ji,jj,ikv) + prd(ji,jj  ,ikv+1) + 2._wp)  ) ! j: 1 
    344501                                  ! + 2 due to the formulation in density and not in anomalie in hpg sco 
    345502               ELSE 
    346                  sgzv  (ji,jj) = fsde3w(ji,jj+1,ikv) - (fsde3w(ji,jj,ikv) - ze3wv) 
    347                  sgrv  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) - zrj(ji,jj) )     ! j: 2 
    348                  smrv  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) + zrj(ji,jj) )     ! j: 2 
    349                  sge3rv(ji,jj) = vmask(ji,jj,ikv+1)                                                                   & 
     503                 pgzvi  (ji,jj) = fsde3w(ji,jj+1,ikv) - (fsde3w(ji,jj,ikv) - ze3wv) 
     504                 pgrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) - zrj(ji,jj) )     ! j: 2 
     505                 pmrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) + zrj(ji,jj) )     ! j: 2 
     506                 pge3rvi(ji,jj) = vmask(ji,jj,ikv+1)                                                                   & 
    350507                                * (  fse3w(ji,jj+1,ikv+1)          * ( prd(ji,jj+1,ikv) + prd(ji,jj+1,ikv+1) + 2._wp) & 
    351508                                   -(fse3w(ji,jj  ,ikv+1) + ze3wv) * ( zrj(ji,jj      ) + prd(ji,jj  ,ikv+1) + 2._wp) )  ! j: 2 
     
    353510            END DO 
    354511         END DO 
    355          CALL lbc_lnk( sgru   , 'U', -1. )   ;   CALL lbc_lnk( sgrv   , 'V', -1. )   ! Lateral boundary conditions 
    356          CALL lbc_lnk( smru   , 'U',  1. )   ;   CALL lbc_lnk( smrv   , 'V',  1. )   ! Lateral boundary conditions 
    357          CALL lbc_lnk( sgzu   , 'U', -1. )   ;   CALL lbc_lnk( sgzv   , 'V', -1. )   ! Lateral boundary conditions 
    358          CALL lbc_lnk( sge3ru , 'U', -1. )   ;   CALL lbc_lnk( sge3rv , 'V', -1. )   ! Lateral boundary conditions 
     512         CALL lbc_lnk( pgrui   , 'U', -1. )   ;   CALL lbc_lnk( pgrvi   , 'V', -1. )   ! Lateral boundary conditions 
     513         CALL lbc_lnk( pmrui   , 'U',  1. )   ;   CALL lbc_lnk( pmrvi   , 'V',  1. )   ! Lateral boundary conditions 
     514         CALL lbc_lnk( pgzui   , 'U', -1. )   ;   CALL lbc_lnk( pgzvi   , 'V', -1. )   ! Lateral boundary conditions 
     515         CALL lbc_lnk( pge3rui , 'U', -1. )   ;   CALL lbc_lnk( pge3rvi , 'V', -1. )   ! Lateral boundary conditions 
    359516         ! 
    360517      END IF   
    361518      ! 
    362       IF( nn_timing == 1 )  CALL timing_stop( 'zps_hde') 
    363       ! 
    364    END SUBROUTINE zps_hde 
    365  
     519      IF( nn_timing == 1 )  CALL timing_stop( 'zps_hde_isf') 
     520      ! 
     521   END SUBROUTINE zps_hde_isf 
    366522   !!====================================================================== 
    367523END MODULE zpshde 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trd_oce.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    7676   !!---------------------------------------------------------------------- 
    7777   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    78    !! $Id: trd_oce.F90 3318 2012-02-25 15:50:01Z gm $ 
     78   !! $Id$ 
    7979   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    8080   !!====================================================================== 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trddyn.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    4040   !!---------------------------------------------------------------------- 
    4141   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    42    !! $Id: trddyn.F90 3325 2012-03-12 14:44:43Z gm $ 
     42   !! $Id$ 
    4343   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4444   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdglo.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    5656   !!---------------------------------------------------------------------- 
    5757   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    58    !! $Id: trdglo.F90 3325 2012-03-12 14:44:43Z gm $ 
     58   !! $Id$ 
    5959   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    6060   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdini.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    3030   !!---------------------------------------------------------------------- 
    3131   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    32    !! $Id: trdini.F90 3329 2012-03-16 12:22:15Z gm $ 
     32   !! $Id$ 
    3333   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3434   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdken.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    4444   !!---------------------------------------------------------------------- 
    4545   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    46    !! $Id: trdken.F90 3329 2012-03-16 12:22:15Z gm $ 
     46   !! $Id$ 
    4747   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4848   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    7777   !!---------------------------------------------------------------------- 
    7878   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    79    !! $Id: trdmxl.F90 3318 2012-02-25 15:50:01Z gm $  
     79   !! $Id$  
    8080   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    8181   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl_oce.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    8383   !!---------------------------------------------------------------------- 
    8484   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    85    !! $Id: $  
     85   !! $Id$  
    8686   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    8787   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl_rst.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    2727   !!--------------------------------------------------------------------------------- 
    2828   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    29    !! $Id: $  
     29   !! $Id$ 
    3030   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    3131   !!--------------------------------------------------------------------------------- 
     
    4343      INTEGER ::   jk                 ! loop indice 
    4444      CHARACTER(LEN=20)   ::   clkt     ! ocean time-step deine as a character 
    45       CHARACTER(LEN=50)   ::   clname   ! ice output restart file name 
     45      CHARACTER(LEN=50)   ::   clname   ! output restart file name 
     46      CHARACTER(LEN=256)  ::   clpath   ! full path to restart file 
    4647      !!-------------------------------------------------------------------------------- 
    4748 
     
    5657         ! create the file 
    5758         clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_trdrst_out) 
     59         clpath = TRIM(cn_ocerst_outdir) 
     60         IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 
    5861         IF(lwp) THEN 
    5962            WRITE(numout,*) 
     
    6770         ENDIF 
    6871 
    69          CALL iom_open( clname, nummxlw, ldwrt = .TRUE., kiolib = jprstlib ) 
     72         CALL iom_open( TRIM(clpath)//TRIM(clname), nummxlw, ldwrt = .TRUE., kiolib = jprstlib ) 
    7073      ENDIF 
    7174 
     
    133136      INTEGER ::   jlibalt = jprstlib 
    134137      LOGICAL ::   llok 
     138      CHARACTER(LEN=256)  ::   clpath   ! full path to restart file 
    135139      !!----------------------------------------------------------------------------- 
    136140 
     
    140144         WRITE(numout,*) ' ~~~~~~~~~~~~~~~~' 
    141145      ENDIF 
     146 
     147      clpath = TRIM(cn_ocerst_indir) 
     148      IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 
     149 
    142150      IF ( jprstlib == jprstdimg ) THEN 
    143151         ! eventually read netcdf file (monobloc)  for restarting on different number of processors 
    144152         ! if {cn_trdrst_in}.nc exists, then set jlibalt to jpnf90 
    145          INQUIRE( FILE = TRIM(cn_trdrst_in)//'.nc', EXIST = llok ) 
     153         INQUIRE( FILE = TRIM(clpath)//TRIM(cn_trdrst_in)//'.nc', EXIST = llok ) 
    146154         IF ( llok ) THEN   ;   jlibalt = jpnf90    
    147155         ELSE               ;   jlibalt = jprstlib    
     
    149157      ENDIF 
    150158 
    151       CALL iom_open( cn_trdrst_in, inum, kiolib = jlibalt )  
     159      CALL iom_open( TRIM(clpath)//TRIM(cn_trdrst_in), inum, kiolib = jlibalt )  
    152160 
    153161      IF( ln_trdmxl_instant ) THEN  
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdpen.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    4141   !!---------------------------------------------------------------------- 
    4242   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    43    !! $Id: trdtra.F90 3318 2012-02-25 15:50:01Z gm $ 
     43   !! $Id$ 
    4444   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4545   !!---------------------------------------------------------------------- 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdtrc.F90

    • Property svn:keywords set to Id
    r5038 r5620  
    1818   !!---------------------------------------------------------------------- 
    1919   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    20    !! $Id: trdtrc.F90 2715 2011-03-30 15:58:35Z rblod $ 
     20   !! $Id$ 
    2121   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    2222   !!====================================================================== 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfbfr.F90

    r5038 r5620  
    120120                  zbfrt(ji,jj) = MAX(bfrcoef2d(ji,jj), ztmp) 
    121121                  zbfrt(ji,jj) = MIN(zbfrt(ji,jj), rn_bfri2_max) 
    122 ! (ISF) 
    123                   ikbt = mikt(ji,jj) 
    124 ! JC: possible WAD implementation should modify line below if layers vanish 
    125                   ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp 
    126                   ztfrt(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp) 
    127                   ztfrt(ji,jj) = MIN(ztfrt(ji,jj), rn_tfri2_max) 
    128  
    129122               END DO 
    130123            END DO 
     124! (ISF) 
     125            IF ( ln_isfcav ) THEN 
     126               DO jj = 1, jpj 
     127                  DO ji = 1, jpi 
     128                     ikbt = mikt(ji,jj) 
     129! JC: possible WAD implementation should modify line below if layers vanish 
     130                     ztmp = (1-tmask(ji,jj,1)) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp 
     131                     ztfrt(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp) 
     132                     ztfrt(ji,jj) = MIN(ztfrt(ji,jj), rn_tfri2_max) 
     133                  END DO 
     134               END DO 
     135            END IF 
    131136         !    
    132137         ELSE 
     
    152157               ! 
    153158               ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 
    154                IF ( miku(ji,jj) + 2 .GE. mbku(ji,jj) ) THEN 
    155                   bfrua(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji+1,jj  ) )   & 
    156                                &            + ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) ) ) & 
    157                                &          * zecu * (1._wp - umask(ji,jj,1)) 
    158                END IF 
    159                IF ( mikv(ji,jj) + 2 .GE. mbkv(ji,jj) ) THEN 
    160                   bfrva(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji  ,jj+1) )   & 
    161                                &            + ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) ) ) & 
    162                                &          * zecv * (1._wp - vmask(ji,jj,1)) 
    163                END IF 
    164                ! (ISF) ======================================================================== 
    165                ikbu = miku(ji,jj)         ! ocean bottom level at u- and v-points  
    166                ikbv = mikv(ji,jj)         ! (deepest ocean u- and v-points) 
    167                ! 
    168                zvu  = 0.25 * (  vn(ji,jj  ,ikbu) + vn(ji+1,jj  ,ikbu)     & 
    169                   &           + vn(ji,jj-1,ikbu) + vn(ji+1,jj-1,ikbu)  ) 
    170                zuv  = 0.25 * (  un(ji,jj  ,ikbv) + un(ji-1,jj  ,ikbv)     & 
    171                   &           + un(ji,jj+1,ikbv) + un(ji-1,jj+1,ikbv)  ) 
    172                ! 
    173                zecu = SQRT(  un(ji,jj,ikbu) * un(ji,jj,ikbu) + zvu*zvu + rn_bfeb2 ) 
    174                zecv = SQRT(  vn(ji,jj,ikbv) * vn(ji,jj,ikbv) + zuv*zuv + rn_bfeb2 ) 
    175                ! 
    176                tfrua(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) ) * zecu * (1._wp - umask(ji,jj,1)) 
    177                tfrva(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) ) * zecv * (1._wp - vmask(ji,jj,1)) 
    178                ! (ISF) END ==================================================================== 
    179                ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 
    180                IF ( miku(ji,jj) + 2 .GE. mbku(ji,jj) ) THEN 
    181                   tfrua(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) )   & 
    182                                &            + ( zbfrt(ji,jj) + zbfrt(ji+1,jj  ) ) ) & 
    183                                &          * zecu * (1._wp - umask(ji,jj,1)) 
    184                END IF 
    185                IF ( mikv(ji,jj) + 2 .GE. mbkv(ji,jj) ) THEN 
    186                   tfrva(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) )   & 
    187                                &            + ( zbfrt(ji,jj) + zbfrt(ji  ,jj+1) ) ) & 
    188                                &          * zecv * (1._wp - vmask(ji,jj,1)) 
     159               IF ( ln_isfcav ) THEN 
     160                  IF ( miku(ji,jj) + 1 .GE. mbku(ji,jj) ) THEN 
     161                     bfrua(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji+1,jj  ) )   & 
     162                                  &            + ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) ) ) & 
     163                                  &          * zecu * (1._wp - umask(ji,jj,1)) 
     164                  END IF 
     165                  IF ( mikv(ji,jj) + 1 .GE. mbkv(ji,jj) ) THEN 
     166                     bfrva(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji  ,jj+1) )   & 
     167                                  &            + ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) ) ) & 
     168                                  &          * zecv * (1._wp - vmask(ji,jj,1)) 
     169                  END IF 
    189170               END IF 
    190171            END DO 
    191172         END DO 
    192          ! 
    193173         CALL lbc_lnk( bfrua, 'U', 1. )   ;   CALL lbc_lnk( bfrva, 'V', 1. )      ! Lateral boundary condition 
     174 
     175         IF ( ln_isfcav ) THEN 
     176            DO jj = 2, jpjm1 
     177               DO ji = 2, jpim1 
     178                  ! (ISF) ======================================================================== 
     179                  ikbu = miku(ji,jj)         ! ocean top level at u- and v-points  
     180                  ikbv = mikv(ji,jj)         ! (1st wet ocean u- and v-points) 
     181                  ! 
     182                  zvu  = 0.25 * (  vn(ji,jj  ,ikbu) + vn(ji+1,jj  ,ikbu)     & 
     183                     &           + vn(ji,jj-1,ikbu) + vn(ji+1,jj-1,ikbu)  ) 
     184                  zuv  = 0.25 * (  un(ji,jj  ,ikbv) + un(ji-1,jj  ,ikbv)     & 
     185                     &           + un(ji,jj+1,ikbv) + un(ji-1,jj+1,ikbv)  ) 
     186              ! 
     187                  zecu = SQRT(  un(ji,jj,ikbu) * un(ji,jj,ikbu) + zvu*zvu + rn_tfeb2 ) 
     188                  zecv = SQRT(  vn(ji,jj,ikbv) * vn(ji,jj,ikbv) + zuv*zuv + rn_tfeb2 ) 
     189              ! 
     190                  tfrua(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) ) * zecu * (1._wp - umask(ji,jj,1)) 
     191                  tfrva(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) ) * zecv * (1._wp - vmask(ji,jj,1)) 
     192              ! (ISF) END ==================================================================== 
     193              ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 
     194                  IF ( miku(ji,jj) + 1 .GE. mbku(ji,jj) ) THEN 
     195                     tfrua(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) )   & 
     196                                  &            + ( zbfrt(ji,jj) + zbfrt(ji+1,jj  ) ) ) & 
     197                                  &          * zecu * (1._wp - umask(ji,jj,1)) 
     198                  END IF 
     199                  IF ( mikv(ji,jj) + 1 .GE. mbkv(ji,jj) ) THEN 
     200                     tfrva(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) )   & 
     201                                  &            + ( zbfrt(ji,jj) + zbfrt(ji  ,jj+1) ) ) & 
     202                                  &          * zecv * (1._wp - vmask(ji,jj,1)) 
     203                  END IF 
     204               END DO 
     205            END DO 
     206            CALL lbc_lnk( tfrua, 'U', 1. )   ;   CALL lbc_lnk( tfrva, 'V', 1. )      ! Lateral boundary condition 
     207         END IF 
     208         ! 
    194209         ! 
    195210         IF(ln_ctl)   CALL prt_ctl( tab2d_1=bfrua, clinfo1=' bfr  - u: ', mask1=umask,        & 
     
    264279            IF(lwp) WRITE(numout,*) '      coef rn_bfri2 enhancement factor                rn_bfrien  = ',rn_bfrien 
    265280         ENDIF 
    266          IF(lwp) WRITE(numout,*) '      top    friction coef.   rn_bfri1  = ', rn_bfri1 
    267          IF( ln_tfr2d ) THEN 
    268             IF(lwp) WRITE(numout,*) '      read coef. enhancement distribution from file   ln_tfr2d  = ', ln_tfr2d 
    269             IF(lwp) WRITE(numout,*) '      coef rn_tfri2 enhancement factor                rn_tfrien  = ',rn_tfrien 
    270          ENDIF 
     281         IF ( ln_isfcav ) THEN 
     282            IF(lwp) WRITE(numout,*) '      top    friction coef.   rn_bfri1  = ', rn_tfri1 
     283            IF( ln_tfr2d ) THEN 
     284               IF(lwp) WRITE(numout,*) '      read coef. enhancement distribution from file   ln_tfr2d  = ', ln_tfr2d 
     285               IF(lwp) WRITE(numout,*) '      coef rn_tfri2 enhancement factor                rn_tfrien  = ',rn_tfrien 
     286            ENDIF 
     287         END IF 
    271288         ! 
    272289         IF(ln_bfr2d) THEN 
     
    282299         bfrua(:,:) = - bfrcoef2d(:,:) 
    283300         bfrva(:,:) = - bfrcoef2d(:,:) 
     301         ! 
     302         IF ( ln_isfcav ) THEN 
     303            IF(ln_tfr2d) THEN 
     304               ! tfr_coef is a coefficient in [0,1] giving the mask where to apply the bfr enhancement 
     305               CALL iom_open('tfr_coef.nc',inum) 
     306               CALL iom_get (inum, jpdom_data, 'tfr_coef',tfrcoef2d,1) ! tfrcoef2d is used as tmp array 
     307               CALL iom_close(inum) 
     308               tfrcoef2d(:,:) = rn_tfri1 * ( 1 + rn_tfrien * tfrcoef2d(:,:) ) 
     309            ELSE 
     310               tfrcoef2d(:,:) = rn_tfri1  ! initialize tfrcoef2d to the namelist variable 
     311            ENDIF 
     312            ! 
     313            tfrua(:,:) = - tfrcoef2d(:,:) 
     314            tfrva(:,:) = - tfrcoef2d(:,:) 
     315         END IF 
    284316         ! 
    285317      CASE( 2 ) 
     
    298330            IF(lwp) WRITE(numout,*) '      coef rn_bfri2 enhancement factor                rn_bfrien  = ',rn_bfrien 
    299331         ENDIF 
    300          IF(lwp) WRITE(numout,*) '      quadratic top    friction' 
    301          IF(lwp) WRITE(numout,*) '      friction coef.   rn_bfri2  = ', rn_tfri2 
    302          IF(lwp) WRITE(numout,*) '      Max. coef. (log case)   rn_tfri2_max  = ', rn_tfri2_max 
    303          IF(lwp) WRITE(numout,*) '      background tke   rn_tfeb2  = ', rn_tfeb2 
    304          IF(lwp) WRITE(numout,*) '      log formulation   ln_tfr2d = ', ln_loglayer 
    305          IF(lwp) WRITE(numout,*) '      bottom roughness  rn_tfrz0 [m] = ', rn_tfrz0 
    306          IF( rn_tfrz0<=0.e0 ) THEN 
    307             WRITE(ctmp1,*) '      bottom roughness must be strictly positive' 
    308             CALL ctl_stop( ctmp1 ) 
    309          ENDIF 
    310          IF( ln_tfr2d ) THEN 
    311             IF(lwp) WRITE(numout,*) '      read coef. enhancement distribution from file   ln_tfr2d  = ', ln_tfr2d 
    312             IF(lwp) WRITE(numout,*) '      coef rn_tfri2 enhancement factor                rn_tfrien  = ',rn_tfrien 
    313          ENDIF 
     332         IF ( ln_isfcav ) THEN 
     333            IF(lwp) WRITE(numout,*) '      quadratic top    friction' 
     334            IF(lwp) WRITE(numout,*) '      friction coef.    rn_tfri2     = ', rn_tfri2 
     335            IF(lwp) WRITE(numout,*) '      Max. coef. (log case)   rn_tfri2_max  = ', rn_tfri2_max 
     336            IF(lwp) WRITE(numout,*) '      background tke    rn_tfeb2     = ', rn_tfeb2 
     337            IF(lwp) WRITE(numout,*) '      log formulation   ln_tfr2d     = ', ln_loglayer 
     338            IF(lwp) WRITE(numout,*) '      top roughness     rn_tfrz0 [m] = ', rn_tfrz0 
     339            IF( rn_tfrz0<=0.e0 ) THEN 
     340               WRITE(ctmp1,*) '      top roughness must be strictly positive' 
     341               CALL ctl_stop( ctmp1 ) 
     342            ENDIF 
     343            IF( ln_tfr2d ) THEN 
     344               IF(lwp) WRITE(numout,*) '      read coef. enhancement distribution from file   ln_tfr2d  = ', ln_tfr2d 
     345               IF(lwp) WRITE(numout,*) '      coef rn_tfri2 enhancement factor                rn_tfrien  = ',rn_tfrien 
     346            ENDIF 
     347         END IF 
    314348         ! 
    315349         IF(ln_bfr2d) THEN 
     
    323357            bfrcoef2d(:,:) = rn_bfri2  ! initialize bfrcoef2d to the namelist variable 
    324358         ENDIF 
     359          
     360         IF ( ln_isfcav ) THEN 
     361            IF(ln_tfr2d) THEN 
     362               ! tfr_coef is a coefficient in [0,1] giving the mask where to apply the bfr enhancement 
     363               CALL iom_open('tfr_coef.nc',inum) 
     364               CALL iom_get (inum, jpdom_data, 'tfr_coef',tfrcoef2d,1) ! tfrcoef2d is used as tmp array 
     365               CALL iom_close(inum) 
     366               ! 
     367               tfrcoef2d(:,:) = rn_tfri2 * ( 1 + rn_tfrien * tfrcoef2d(:,:) ) 
     368            ELSE 
     369               tfrcoef2d(:,:) = rn_tfri2  ! initialize tfrcoef2d to the namelist variable 
     370            ENDIF 
     371         END IF 
    325372         ! 
    326373         IF ( ln_loglayer.AND.(.NOT.lk_vvl) ) THEN ! set "log layer" bottom friction once for all 
     
    333380               END DO 
    334381            END DO 
     382            IF ( ln_isfcav ) THEN 
     383               DO jj = 1, jpj 
     384                  DO ji = 1, jpi 
     385                     ikbt = mikt(ji,jj) 
     386                     ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_tfrz0 ))**2._wp 
     387                     tfrcoef2d(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp) 
     388                     tfrcoef2d(ji,jj) = MIN(tfrcoef2d(ji,jj), rn_tfri2_max) 
     389                  END DO 
     390               END DO 
     391            END IF 
    335392         ENDIF 
    336393         ! 
     
    385442             zminbfr = MIN(  zminbfr, MIN( zfru, ABS( bfrcoef2d(ji,jj) ) )  ) 
    386443             zmaxbfr = MAX(  zmaxbfr, MIN( zfrv, ABS( bfrcoef2d(ji,jj) ) )  ) 
     444! (ISF) 
     445             IF ( ln_isfcav ) THEN 
     446                ikbu = miku(ji,jj)       ! 1st wet ocean level at u- and v-points 
     447                ikbv = mikv(ji,jj) 
     448                zfru = 0.5 * fse3u(ji,jj,ikbu) / rdt 
     449                zfrv = 0.5 * fse3v(ji,jj,ikbv) / rdt 
     450                IF( ABS( tfrcoef2d(ji,jj) ) > zfru ) THEN 
     451                   IF( ln_ctl ) THEN 
     452                      WRITE(numout,*) 'TFR ', narea, nimpp+ji, njmpp+jj, ikbu 
     453                      WRITE(numout,*) 'TFR ', ABS( tfrcoef2d(ji,jj) ), zfru 
     454                   ENDIF 
     455                   ictu = ictu + 1 
     456                ENDIF 
     457                IF( ABS( tfrcoef2d(ji,jj) ) > zfrv ) THEN 
     458                   IF( ln_ctl ) THEN 
     459                      WRITE(numout,*) 'TFR ', narea, nimpp+ji, njmpp+jj, ikbv 
     460                      WRITE(numout,*) 'TFR ', tfrcoef2d(ji,jj), zfrv 
     461                   ENDIF 
     462                   ictv = ictv + 1 
     463                ENDIF 
     464                zmintfr = MIN(  zmintfr, MIN( zfru, ABS( tfrcoef2d(ji,jj) ) )  ) 
     465                zmaxtfr = MAX(  zmaxtfr, MIN( zfrv, ABS( tfrcoef2d(ji,jj) ) )  ) 
     466             END IF 
     467! END ISF 
    387468         END DO 
    388469      END DO 
     
    392473         CALL mpp_min( zminbfr ) 
    393474         CALL mpp_max( zmaxbfr ) 
     475         IF ( ln_isfcav) CALL mpp_min( zmintfr ) 
     476         IF ( ln_isfcav) CALL mpp_max( zmaxtfr ) 
    394477      ENDIF 
    395478      IF( .NOT.ln_bfrimp) THEN 
    396479      IF( lwp .AND. ictu + ictv > 0 ) THEN 
    397          WRITE(numout,*) ' Bottom friction stability check failed at ', ictu, ' U-points ' 
    398          WRITE(numout,*) ' Bottom friction stability check failed at ', ictv, ' V-points ' 
     480         WRITE(numout,*) ' Bottom/Top friction stability check failed at ', ictu, ' U-points ' 
     481         WRITE(numout,*) ' Bottom/Top friction stability check failed at ', ictv, ' V-points ' 
    399482         WRITE(numout,*) ' Bottom friction coefficient now ranges from: ', zminbfr, ' to ', zmaxbfr 
    400          WRITE(numout,*) ' Bottom friction coefficient now ranges from: ', zmintfr, ' to ', zmaxtfr 
    401          WRITE(numout,*) ' Bottom friction coefficient will be reduced where necessary' 
     483         IF ( ln_isfcav ) WRITE(numout,*) ' Top friction coefficient now ranges from: ', zmintfr, ' to ', zmaxtfr 
     484         WRITE(numout,*) ' Bottom/Top friction coefficient will be reduced where necessary' 
    402485      ENDIF 
    403486      ENDIF 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90

    r5038 r5620  
    156156         END DO 
    157157         ! mask zmsk in order to have avt and avs masked 
    158          zmsks(:,:) = zmsks(:,:) * tmask(:,:,jk) 
     158         zmsks(:,:) = zmsks(:,:) * wmask(:,:,jk) 
    159159 
    160160 
     
    191191               avmu(ji,jj,jk) = MAX( avmu(ji,jj,jk),    & 
    192192                  &                  avt(ji,jj,jk), avt(ji+1,jj,jk),   & 
    193                   &                  avs(ji,jj,jk), avs(ji+1,jj,jk) )  * umask(ji,jj,jk) 
     193                  &                  avs(ji,jj,jk), avs(ji+1,jj,jk) )  * wumask(ji,jj,jk) 
    194194               avmv(ji,jj,jk) = MAX( avmv(ji,jj,jk),    & 
    195195                  &                  avt(ji,jj,jk), avt(ji,jj+1,jk),   & 
    196                   &                  avs(ji,jj,jk), avs(ji,jj+1,jk) )  * vmask(ji,jj,jk) 
     196                  &                  avs(ji,jj,jk), avs(ji,jj+1,jk) )  * wvmask(ji,jj,jk) 
    197197            END DO 
    198198         END DO 
     
    255255      IF( zdf_ddm_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_ddm_init : unable to allocate arrays' ) 
    256256      !                               ! initialization to masked Kz 
    257       avs(:,:,:) = rn_avt0 * tmask(:,:,:)  
     257      avs(:,:,:) = rn_avt0 * wmask(:,:,:)  
    258258      ! 
    259259   END SUBROUTINE zdf_ddm_init 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r5038 r5620  
    2020   USE domvvl         ! ocean space and time domain : variable volume layer 
    2121   USE zdf_oce        ! ocean vertical physics 
     22   USE zdfbfr         ! bottom friction (only for rn_bfrz0) 
    2223   USE sbc_oce        ! surface boundary condition: ocean 
    2324   USE phycst         ! physical constants 
     
    5253 
    5354   !                              !! ** Namelist  namzdf_gls  ** 
    54    LOGICAL  ::   ln_crban          ! =T use Craig and Banner scheme 
    5555   LOGICAL  ::   ln_length_lim     ! use limit on the dissipation rate under stable stratification (Galperin et al. 1988) 
    5656   LOGICAL  ::   ln_sigpsi         ! Activate Burchard (2003) modification for k-eps closure & wave breaking mixing 
    57    INTEGER  ::   nn_tkebc_surf     ! TKE surface boundary condition (=0/1) 
    58    INTEGER  ::   nn_tkebc_bot      ! TKE bottom boundary condition (=0/1) 
    59    INTEGER  ::   nn_psibc_surf     ! PSI surface boundary condition (=0/1) 
    60    INTEGER  ::   nn_psibc_bot      ! PSI bottom boundary condition (=0/1) 
     57   INTEGER  ::   nn_bc_surf        ! surface boundary condition (=0/1) 
     58   INTEGER  ::   nn_bc_bot         ! bottom boundary condition (=0/1) 
     59   INTEGER  ::   nn_z0_met         ! Method for surface roughness computation 
    6160   INTEGER  ::   nn_stab_func      ! stability functions G88, KC or Canuto (=0/1/2) 
    6261   INTEGER  ::   nn_clos           ! closure 0/1/2/3 MY82/k-eps/k-w/gen 
     
    6665   REAL(wp) ::   rn_charn          ! Charnock constant for surface breaking waves mixing : 1400. (standard) or 2.e5 (Stacey value) 
    6766   REAL(wp) ::   rn_crban          ! Craig and Banner constant for surface breaking waves mixing 
    68  
    69    REAL(wp) ::   hsro          =  0.003_wp    ! Minimum surface roughness 
    70    REAL(wp) ::   hbro          =  0.003_wp    ! Bottom roughness (m) 
     67   REAL(wp) ::   rn_hsro           ! Minimum surface roughness 
     68   REAL(wp) ::   rn_frac_hs        ! Fraction of wave height as surface roughness (if nn_z0_met > 1)  
     69 
    7170   REAL(wp) ::   rcm_sf        =  0.73_wp     ! Shear free turbulence parameters 
    7271   REAL(wp) ::   ra_sf         = -2.0_wp      ! Must be negative -2 < ra_sf < -1  
     
    9695   REAL(wp) ::   rm7           =  0.0_wp 
    9796   REAL(wp) ::   rm8           =  0.318_wp 
    98     
     97   REAL(wp) ::   rtrans        =  0.1_wp 
    9998   REAL(wp) ::   rc02, rc02r, rc03, rc04                          ! coefficients deduced from above parameters 
    100    REAL(wp) ::   rc03_sqrt2_galp                                  !     -           -           -        - 
    101    REAL(wp) ::   rsbc_tke1, rsbc_tke2, rsbc_tke3, rfact_tke       !     -           -           -        - 
    102    REAL(wp) ::   rsbc_psi1, rsbc_psi2, rsbc_psi3, rfact_psi       !     -           -           -        - 
    103    REAL(wp) ::   rsbc_mb  , rsbc_std , rsbc_zs                    !     -           -           -        - 
     99   REAL(wp) ::   rsbc_tke1, rsbc_tke2, rfact_tke                  !     -           -           -        - 
     100   REAL(wp) ::   rsbc_psi1, rsbc_psi2, rfact_psi                  !     -           -           -        - 
     101   REAL(wp) ::   rsbc_zs1, rsbc_zs2                               !     -           -           -        - 
    104102   REAL(wp) ::   rc0, rc2, rc3, rf6, rcff, rc_diff                !     -           -           -        - 
    105103   REAL(wp) ::   rs0, rs1, rs2, rs4, rs5, rs6                     !     -           -           -        - 
     
    147145      REAL(wp) ::   gh, gm, shr, dif, zsqen, zav        !   -      - 
    148146      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zdep 
     147      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zkar 
    149148      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zflxs       ! Turbulence fluxed induced by internal waves  
    150149      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zhsro       ! Surface roughness (surface waves) 
     
    153152      REAL(wp), POINTER, DIMENSION(:,:,:) ::   shear       ! vertical shear 
    154153      REAL(wp), POINTER, DIMENSION(:,:,:) ::   eps         ! dissipation rate 
    155       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zwall_psi   ! Wall function use in the wb case (ln_sigpsi.AND.ln_crban=T) 
    156       REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_a, z_elem_b, z_elem_c, psi 
     154      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zwall_psi   ! Wall function use in the wb case (ln_sigpsi) 
     155      REAL(wp), POINTER, DIMENSION(:,:,:) ::   psi         ! psi at time now 
     156      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_a    ! element of the first  matrix diagonal 
     157      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_b    ! element of the second matrix diagonal 
     158      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_c    ! element of the third  matrix diagonal 
    157159      !!-------------------------------------------------------------------- 
    158160      ! 
    159161      IF( nn_timing == 1 )  CALL timing_start('zdf_gls') 
    160162      ! 
    161       CALL wrk_alloc( jpi,jpj, zdep, zflxs, zhsro ) 
    162       CALL wrk_alloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi ) 
    163  
     163      CALL wrk_alloc( jpi,jpj, zdep, zkar, zflxs, zhsro ) 
     164      CALL wrk_alloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi  ) 
     165       
    164166      ! Preliminary computing 
    165167 
     
    174176 
    175177      ! Compute surface and bottom friction at T-points 
    176 !CDIR NOVERRCHK 
    177       DO jj = 2, jpjm1 
    178 !CDIR NOVERRCHK 
    179          DO ji = fs_2, fs_jpim1   ! vector opt. 
    180             !  
    181             ! surface friction  
     178!CDIR NOVERRCHK           
     179      DO jj = 2, jpjm1           
     180!CDIR NOVERRCHK          
     181         DO ji = fs_2, fs_jpim1   ! vector opt.          
     182            ! 
     183            ! surface friction 
    182184            ustars2(ji,jj) = r1_rau0 * taum(ji,jj) * tmask(ji,jj,1) 
    183             ! 
    184             ! bottom friction (explicit before friction) 
    185             ! Note that we chose here not to bound the friction as in dynbfr) 
    186             ztx2 = (  bfrua(ji,jj)  * ub(ji,jj,mbku(ji,jj)) + bfrua(ji-1,jj) * ub(ji-1,jj,mbku(ji-1,jj))  )   & 
    187                & * ( 1._wp - 0.5_wp * umask(ji,jj,1) * umask(ji-1,jj,1)  ) 
    188             zty2 = (  bfrva(ji,jj)  * vb(ji,jj,mbkv(ji,jj)) + bfrva(ji,jj-1) * vb(ji,jj-1,mbkv(ji,jj-1))  )   & 
    189                & * ( 1._wp - 0.5_wp * vmask(ji,jj,1) * vmask(ji,jj-1,1)  ) 
    190             ustarb2(ji,jj) = SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) 
    191          END DO 
    192       END DO   
    193  
    194       ! In case of breaking surface waves mixing, 
    195       ! Compute surface roughness length according to Charnock formula: 
    196       IF( ln_crban ) THEN   ;   zhsro(:,:) = MAX(rsbc_zs * ustars2(:,:), hsro) 
    197       ELSE                  ;   zhsro(:,:) = hsro 
    198       ENDIF 
     185            !    
     186            ! bottom friction (explicit before friction)         
     187            ! Note that we chose here not to bound the friction as in dynbfr)    
     188            ztx2 = (  bfrua(ji,jj)  * ub(ji,jj,mbku(ji,jj)) + bfrua(ji-1,jj) * ub(ji-1,jj,mbku(ji-1,jj))  )   &          
     189               & * ( 1._wp - 0.5_wp * umask(ji,jj,1) * umask(ji-1,jj,1)  )       
     190            zty2 = (  bfrva(ji,jj)  * vb(ji,jj,mbkv(ji,jj)) + bfrva(ji,jj-1) * vb(ji,jj-1,mbkv(ji,jj-1))  )   &          
     191               & * ( 1._wp - 0.5_wp * vmask(ji,jj,1) * vmask(ji,jj-1,1)  )       
     192            ustarb2(ji,jj) = SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1)          
     193         END DO          
     194      END DO     
     195 
     196      ! Set surface roughness length 
     197      SELECT CASE ( nn_z0_met ) 
     198      ! 
     199      CASE ( 0 )             ! Constant roughness           
     200         zhsro(:,:) = rn_hsro 
     201      CASE ( 1 )             ! Standard Charnock formula 
     202         zhsro(:,:) = MAX(rsbc_zs1 * ustars2(:,:), rn_hsro) 
     203      CASE ( 2 )             ! Roughness formulae according to Rascle et al., Ocean Modelling (2008) 
     204         zdep(:,:)  = 30.*TANH(2.*0.3/(28.*SQRT(MAX(ustars2(:,:),rsmall))))             ! Wave age (eq. 10) 
     205         zhsro(:,:) = MAX(rsbc_zs2 * ustars2(:,:) * zdep(:,:)**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11) 
     206      ! 
     207      END SELECT 
    199208 
    200209      ! Compute shear and dissipation rate 
     
    303312      ! 
    304313      ! Set surface condition on zwall_psi (1 at the bottom) 
    305       IF( ln_sigpsi ) THEN 
    306          zcoef = rsc_psi / rsc_psi0 
    307          DO jj = 2, jpjm1 
    308             DO ji = fs_2, fs_jpim1   ! vector opt. 
    309                zwall_psi(ji,jj,1) = zcoef 
    310             END DO 
    311          END DO 
    312       ENDIF 
    313  
     314      zwall_psi(:,:,1) = zwall_psi(:,:,2) 
     315      zwall_psi(:,:,jpk) = 1. 
     316      ! 
    314317      ! Surface boundary condition on tke 
    315318      ! --------------------------------- 
    316319      ! 
    317       SELECT CASE ( nn_tkebc_surf ) 
     320      SELECT CASE ( nn_bc_surf ) 
    318321      ! 
    319322      CASE ( 0 )             ! Dirichlet case 
    320          ! 
    321          IF (ln_crban) THEN     ! Wave induced mixing case 
    322             !                      ! en(1) = q2(1) = 0.5 * (15.8 * Ccb)^(2/3) * u*^2 
    323             !                      ! balance between the production and the dissipation terms including the wave effect 
    324             en(:,:,1) = MAX( rsbc_tke1 * ustars2(:,:), rn_emin ) 
    325             z_elem_a(:,:,1) = en(:,:,1) 
    326             z_elem_c(:,:,1) = 0._wp 
    327             z_elem_b(:,:,1) = 1._wp 
    328             !  
    329             ! one level below 
    330             en(:,:,2) = MAX( rsbc_tke1 * ustars2(:,:) * ( (zhsro(:,:)+fsdepw(:,:,2))/zhsro(:,:) )**ra_sf, rn_emin ) 
    331             z_elem_a(:,:,2) = 0._wp 
    332             z_elem_c(:,:,2) = 0._wp 
    333             z_elem_b(:,:,2) = 1._wp 
    334             ! 
    335          ELSE                   ! No wave induced mixing case 
    336             !                      ! en(1) = u*^2/C0^2  &  l(1)  = K*zs 
    337             !                      ! balance between the production and the dissipation terms 
    338             en(:,:,1) = MAX( rc02r * ustars2(:,:), rn_emin ) 
    339             z_elem_a(:,:,1) = en(:,:,1)  
    340             z_elem_c(:,:,1) = 0._wp 
    341             z_elem_b(:,:,1) = 1._wp 
    342             ! 
    343             ! one level below 
    344             en(:,:,2) = MAX( rc02r * ustars2(:,:), rn_emin ) 
    345             z_elem_a(:,:,2) = 0._wp 
    346             z_elem_c(:,:,2) = 0._wp 
    347             z_elem_b(:,:,2) = 1._wp 
    348             ! 
    349          ENDIF 
    350          ! 
     323      ! First level 
     324      en(:,:,1) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1)**(2._wp/3._wp) 
     325      en(:,:,1) = MAX(en(:,:,1), rn_emin)  
     326      z_elem_a(:,:,1) = en(:,:,1) 
     327      z_elem_c(:,:,1) = 0._wp 
     328      z_elem_b(:,:,1) = 1._wp 
     329      !  
     330      ! One level below 
     331      en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2)) & 
     332         &               / zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 
     333      en(:,:,2) = MAX(en(:,:,2), rn_emin ) 
     334      z_elem_a(:,:,2) = 0._wp  
     335      z_elem_c(:,:,2) = 0._wp 
     336      z_elem_b(:,:,2) = 1._wp 
     337      ! 
     338      ! 
    351339      CASE ( 1 )             ! Neumann boundary condition on d(e)/dz 
    352          ! 
    353          IF (ln_crban) THEN ! Shear free case: d(e)/dz= Fw 
    354             ! 
    355             ! Dirichlet conditions at k=1 (Cosmetic) 
    356             en(:,:,1) = MAX( rsbc_tke1 * ustars2(:,:), rn_emin ) 
    357             z_elem_a(:,:,1) = en(:,:,1) 
    358             z_elem_c(:,:,1) = 0._wp 
    359             z_elem_b(:,:,1) = 1._wp 
    360             ! at k=2, set de/dz=Fw 
    361             z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 
    362             z_elem_a(:,:,2) = 0._wp         
    363             zflxs(:,:) = rsbc_tke3 * ustars2(:,:)**1.5_wp * ( (zhsro(:,:)+fsdept(:,:,1) ) / zhsro(:,:) )**(1.5*ra_sf) 
    364             en(:,:,2) = en(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 
    365             ! 
    366          ELSE                   ! No wave induced mixing case: d(e)/dz=0. 
    367             ! 
    368             ! Dirichlet conditions at k=1 (Cosmetic) 
    369             en(:,:,1) = MAX( rc02r * ustars2(:,:), rn_emin ) 
    370             z_elem_a(:,:,1) = en(:,:,1) 
    371             z_elem_c(:,:,1) = 0._wp 
    372             z_elem_b(:,:,1) = 1._wp 
    373             ! at k=2 set de/dz=0.: 
    374             z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2)  ! Remove z_elem_a from z_elem_b 
    375             z_elem_a(:,:,2) = 0._wp 
    376             ! 
    377          ENDIF 
    378          ! 
     340      ! 
     341      ! Dirichlet conditions at k=1 
     342      en(:,:,1)       = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1)**(2._wp/3._wp) 
     343      en(:,:,1)       = MAX(en(:,:,1), rn_emin)       
     344      z_elem_a(:,:,1) = en(:,:,1) 
     345      z_elem_c(:,:,1) = 0._wp 
     346      z_elem_b(:,:,1) = 1._wp 
     347      ! 
     348      ! at k=2, set de/dz=Fw 
     349      !cbr 
     350      z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 
     351      z_elem_a(:,:,2) = 0._wp 
     352      zkar(:,:)       = (rl_sf + (vkarmn-rl_sf)*(1.-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:)) )) 
     353      zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) & 
     354          &                       * ((zhsro(:,:)+fsdept(:,:,1)) / zhsro(:,:) )**(1.5_wp*ra_sf) 
     355 
     356      en(:,:,2) = en(:,:,2) + zflxs(:,:)/fse3w(:,:,2) 
     357      ! 
     358      ! 
    379359      END SELECT 
    380360 
     
    382362      ! -------------------------------- 
    383363      ! 
    384       SELECT CASE ( nn_tkebc_bot ) 
     364      SELECT CASE ( nn_bc_bot ) 
    385365      ! 
    386366      CASE ( 0 )             ! Dirichlet  
     
    457437      !                                            ! set the minimum value of tke  
    458438      en(:,:,:) = MAX( en(:,:,:), rn_emin ) 
    459        
     439 
    460440      !!----------------------------------------!! 
    461441      !!   Solve prognostic equation for psi    !! 
     
    560540      ! --------------------------------- 
    561541      ! 
    562       SELECT CASE ( nn_psibc_surf ) 
     542      SELECT CASE ( nn_bc_surf ) 
    563543      ! 
    564544      CASE ( 0 )             ! Dirichlet boundary conditions 
    565          ! 
    566          IF( ln_crban ) THEN       ! Wave induced mixing case 
    567             !                      ! en(1) = q2(1) = 0.5 * (15.8 * Ccb)^(2/3) * u*^2 
    568             !                      ! balance between the production and the dissipation terms including the wave effect 
    569             zdep(:,:) = rl_sf * zhsro(:,:) 
    570             psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
    571             z_elem_a(:,:,1) = psi(:,:,1) 
    572             z_elem_c(:,:,1) = 0._wp 
    573             z_elem_b(:,:,1) = 1._wp 
    574             ! 
    575             ! one level below 
    576             zex1 = (rmm*ra_sf+rnn) 
    577             zex2 = (rmm*ra_sf) 
    578             zdep(:,:) = ( (zhsro(:,:) + fsdepw(:,:,2))**zex1 ) / zhsro(:,:)**zex2 
    579             psi (:,:,2) = rsbc_psi1 * ustars2(:,:)**rmm * zdep(:,:) * tmask(:,:,1) 
    580             z_elem_a(:,:,2) = 0._wp 
    581             z_elem_c(:,:,2) = 0._wp 
    582             z_elem_b(:,:,2) = 1._wp 
    583             !  
    584          ELSE                   ! No wave induced mixing case 
    585             !                      ! en(1) = u*^2/C0^2  &  l(1)  = K*zs 
    586             !                      ! balance between the production and the dissipation terms 
    587             ! 
    588             zdep(:,:) = vkarmn * zhsro(:,:) 
    589             psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
    590             z_elem_a(:,:,1) = psi(:,:,1) 
    591             z_elem_c(:,:,1) = 0._wp 
    592             z_elem_b(:,:,1) = 1._wp 
    593             ! 
    594             ! one level below 
    595             zdep(:,:) = vkarmn * ( zhsro(:,:) + fsdepw(:,:,2) ) 
    596             psi (:,:,2) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
    597             z_elem_a(:,:,2) = 0._wp 
    598             z_elem_c(:,:,2) = 0._wp 
    599             z_elem_b(:,:,2) = 1. 
    600             ! 
    601          ENDIF 
    602          ! 
     545      ! 
     546      ! Surface value 
     547      zdep(:,:)       = zhsro(:,:) * rl_sf ! Cosmetic 
     548      psi (:,:,1)     = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     549      z_elem_a(:,:,1) = psi(:,:,1) 
     550      z_elem_c(:,:,1) = 0._wp 
     551      z_elem_b(:,:,1) = 1._wp 
     552      ! 
     553      ! One level below 
     554      zkar(:,:)       = (rl_sf + (vkarmn-rl_sf)*(1._wp-exp(-rtrans*fsdepw(:,:,2)/zhsro(:,:) ))) 
     555      zdep(:,:)       = (zhsro(:,:) + fsdepw(:,:,2)) * zkar(:,:) 
     556      psi (:,:,2)     = rc0**rpp * en(:,:,2)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     557      z_elem_a(:,:,2) = 0._wp 
     558      z_elem_c(:,:,2) = 0._wp 
     559      z_elem_b(:,:,2) = 1._wp 
     560      !  
     561      ! 
    603562      CASE ( 1 )             ! Neumann boundary condition on d(psi)/dz 
    604          ! 
    605          IF( ln_crban ) THEN     ! Wave induced mixing case 
    606             ! 
    607             zdep(:,:) = rl_sf * zhsro(:,:) 
    608             psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
    609             z_elem_a(:,:,1) = psi(:,:,1) 
    610             z_elem_c(:,:,1) = 0._wp 
    611             z_elem_b(:,:,1) = 1._wp 
    612             ! 
    613             ! Neumann condition at k=2 
    614             z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 
    615             z_elem_a(:,:,2) = 0._wp 
    616             ! 
    617             ! Set psi vertical flux at the surface: 
    618             zdep(:,:) = (zhsro(:,:) + fsdept(:,:,1))**(rmm*ra_sf+rnn-1._wp) / zhsro(:,:)**(rmm*ra_sf) 
    619             zflxs(:,:) = rsbc_psi3 * ( zwall_psi(:,:,1)*avm(:,:,1) + zwall_psi(:,:,2)*avm(:,:,2) ) &  
    620                &                   * en(:,:,1)**rmm * zdep          
    621             psi(:,:,2) = psi(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 
    622             ! 
    623       ELSE                   ! No wave induced mixing 
    624             ! 
    625             zdep(:,:) = vkarmn * zhsro(:,:) 
    626             psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
    627             z_elem_a(:,:,1) = psi(:,:,1) 
    628             z_elem_c(:,:,1) = 0._wp 
    629             z_elem_b(:,:,1) = 1._wp 
    630             ! 
    631             ! Neumann condition at k=2 
    632             z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 
    633             z_elem_a(ji,jj,2) = 0._wp 
    634             ! 
    635             ! Set psi vertical flux at the surface: 
    636             zdep(:,:)  = zhsro(:,:) + fsdept(:,:,1) 
    637             zflxs(:,:) = rsbc_psi2 * ( avm(:,:,1) + avm(:,:,2) ) * en(:,:,1)**rmm * zdep**(rnn-1._wp) 
    638             psi(:,:,2) = psi(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 
    639             !      
    640          ENDIF 
    641          ! 
     563      ! 
     564      ! Surface value: Dirichlet 
     565      zdep(:,:)       = zhsro(:,:) * rl_sf 
     566      psi (:,:,1)     = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     567      z_elem_a(:,:,1) = psi(:,:,1) 
     568      z_elem_c(:,:,1) = 0._wp 
     569      z_elem_b(:,:,1) = 1._wp 
     570      ! 
     571      ! Neumann condition at k=2 
     572      z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 
     573      z_elem_a(:,:,2) = 0._wp 
     574      ! 
     575      ! Set psi vertical flux at the surface: 
     576      zkar(:,:) = rl_sf + (vkarmn-rl_sf)*(1._wp-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:) )) ! Lengh scale slope 
     577      zdep(:,:) = ((zhsro(:,:) + fsdept(:,:,1)) / zhsro(:,:))**(rmm*ra_sf) 
     578      zflxs(:,:) = (rnn + rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:))*(1._wp + rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp) 
     579      zdep(:,:) =  rsbc_psi1 * (zwall_psi(:,:,1)*avm(:,:,1)+zwall_psi(:,:,2)*avm(:,:,2)) * & 
     580             & ustars2(:,:)**rmm * zkar(:,:)**rnn * (zhsro(:,:) + fsdept(:,:,1))**(rnn-1.) 
     581      zflxs(:,:) = zdep(:,:) * zflxs(:,:) 
     582      psi(:,:,2) = psi(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 
     583 
     584      !    
     585      ! 
    642586      END SELECT 
    643587 
     
    645589      ! -------------------------------- 
    646590      ! 
    647       SELECT CASE ( nn_psibc_bot ) 
     591      SELECT CASE ( nn_bc_bot ) 
     592      ! 
    648593      ! 
    649594      CASE ( 0 )             ! Dirichlet  
    650          !                      ! en(ibot) = u*^2 / Co2 and mxln(ibot) = vkarmn * hbro 
     595         !                      ! en(ibot) = u*^2 / Co2 and mxln(ibot) = vkarmn * rn_bfrz0 
    651596         !                      ! Balance between the production and the dissipation terms 
    652597!CDIR NOVERRCHK 
     
    656601               ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point 
    657602               ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1 
    658                zdep(ji,jj) = vkarmn * hbro 
     603               zdep(ji,jj) = vkarmn * rn_bfrz0 
    659604               psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 
    660605               z_elem_a(ji,jj,ibot) = 0._wp 
     
    663608               ! 
    664609               ! Just above last level, Dirichlet condition again (GOTM like) 
    665                zdep(ji,jj) = vkarmn * ( hbro + fse3t(ji,jj,ibotm1) ) 
     610               zdep(ji,jj) = vkarmn * ( rn_bfrz0 + fse3t(ji,jj,ibotm1) ) 
    666611               psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot  )**rmm * zdep(ji,jj)**rnn 
    667612               z_elem_a(ji,jj,ibotm1) = 0._wp 
     
    681626               ! 
    682627               ! Bottom level Dirichlet condition: 
    683                zdep(ji,jj) = vkarmn * hbro 
     628               zdep(ji,jj) = vkarmn * rn_bfrz0 
    684629               psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 
    685630               ! 
     
    693638               ! 
    694639               ! Set psi vertical flux at the bottom: 
    695                zdep(ji,jj) = hbro + 0.5_wp*fse3t(ji,jj,ibotm1) 
     640               zdep(ji,jj) = rn_bfrz0 + 0.5_wp*fse3t(ji,jj,ibotm1) 
    696641               zflxb = rsbc_psi2 * ( avm(ji,jj,ibot) + avm(ji,jj,ibotm1) )   & 
    697642                  &  * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp) 
     
    736681            DO jj = 2, jpjm1 
    737682               DO ji = fs_2, fs_jpim1   ! vector opt. 
    738                   eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / psi(ji,jj,jk) 
     683                  eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin) 
    739684               END DO 
    740685            END DO 
     
    783728               ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated)  
    784729               zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 
    785                mxln(ji,jj,jk) = MIN(  rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), mxln(ji,jj,jk) ) 
     730               IF (ln_length_lim) mxln(ji,jj,jk) = MIN(  rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), mxln(ji,jj,jk) ) 
    786731            END DO 
    787732         END DO 
     
    847792      ! Boundary conditions on stability functions for momentum (Neumann): 
    848793      ! Lines below are useless if GOTM style Dirichlet conditions are used 
    849       zcoef = rcm_sf / SQRT( 2._wp ) 
     794 
     795      avmv(:,:,1) = avmv(:,:,2) 
     796 
    850797      DO jj = 2, jpjm1 
    851798         DO ji = fs_2, fs_jpim1   ! vector opt. 
    852             avmv(ji,jj,1) = zcoef 
    853          END DO 
    854       END DO 
    855       zcoef = rc0 / SQRT( 2._wp ) 
    856       DO jj = 2, jpjm1 
    857          DO ji = fs_2, fs_jpim1   ! vector opt. 
    858             avmv(ji,jj,mbkt(ji,jj)+1) = zcoef 
     799            avmv(ji,jj,mbkt(ji,jj)+1) = avmv(ji,jj,mbkt(ji,jj)) 
    859800         END DO 
    860801      END DO 
     
    900841      avmv_k(:,:,:) = avmv(:,:,:) 
    901842      ! 
    902       CALL wrk_dealloc( jpi,jpj, zdep, zflxs, zhsro ) 
     843      CALL wrk_dealloc( jpi,jpj, zdep, zkar, zflxs, zhsro ) 
    903844      CALL wrk_dealloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi ) 
    904845      ! 
     
    932873      !! 
    933874      NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, & 
    934          &            rn_clim_galp, ln_crban, ln_sigpsi,     & 
    935          &            rn_crban, rn_charn,                    & 
    936          &            nn_tkebc_surf, nn_tkebc_bot,           & 
    937          &            nn_psibc_surf, nn_psibc_bot,           & 
     875         &            rn_clim_galp, ln_sigpsi, rn_hsro,      & 
     876         &            rn_crban, rn_charn, rn_frac_hs,        & 
     877         &            nn_bc_surf, nn_bc_bot, nn_z0_met,      & 
    938878         &            nn_stab_func, nn_clos 
    939879      !!---------------------------------------------------------- 
     
    955895         WRITE(numout,*) '~~~~~~~~~~~~' 
    956896         WRITE(numout,*) '   Namelist namzdf_gls : set gls mixing parameters' 
    957          WRITE(numout,*) '      minimum value of en                           rn_emin       = ', rn_emin 
    958          WRITE(numout,*) '      minimum value of eps                          rn_epsmin     = ', rn_epsmin 
    959          WRITE(numout,*) '      Limit dissipation rate under stable stratif.  ln_length_lim = ', ln_length_lim 
    960          WRITE(numout,*) '      Galperin limit (Standard: 0.53, Holt: 0.26)   rn_clim_galp  = ', rn_clim_galp 
    961          WRITE(numout,*) '      TKE Surface boundary condition                nn_tkebc_surf = ', nn_tkebc_surf 
    962          WRITE(numout,*) '      TKE Bottom boundary condition                 nn_tkebc_bot  = ', nn_tkebc_bot 
    963          WRITE(numout,*) '      PSI Surface boundary condition                nn_psibc_surf = ', nn_psibc_surf 
    964          WRITE(numout,*) '      PSI Bottom boundary condition                 nn_psibc_bot  = ', nn_psibc_bot 
    965          WRITE(numout,*) '      Craig and Banner scheme                       ln_crban      = ', ln_crban 
    966          WRITE(numout,*) '      Modify psi Schmidt number (wb case)           ln_sigpsi     = ', ln_sigpsi 
     897         WRITE(numout,*) '      minimum value of en                           rn_emin        = ', rn_emin 
     898         WRITE(numout,*) '      minimum value of eps                          rn_epsmin      = ', rn_epsmin 
     899         WRITE(numout,*) '      Limit dissipation rate under stable stratif.  ln_length_lim  = ', ln_length_lim 
     900         WRITE(numout,*) '      Galperin limit (Standard: 0.53, Holt: 0.26)   rn_clim_galp   = ', rn_clim_galp 
     901         WRITE(numout,*) '      TKE Surface boundary condition                nn_bc_surf     = ', nn_bc_surf 
     902         WRITE(numout,*) '      TKE Bottom boundary condition                 nn_bc_bot      = ', nn_bc_bot 
     903         WRITE(numout,*) '      Modify psi Schmidt number (wb case)           ln_sigpsi      = ', ln_sigpsi 
    967904         WRITE(numout,*) '      Craig and Banner coefficient                  rn_crban       = ', rn_crban 
    968905         WRITE(numout,*) '      Charnock coefficient                          rn_charn       = ', rn_charn 
     906         WRITE(numout,*) '      Surface roughness formula                     nn_z0_met      = ', nn_z0_met 
     907         WRITE(numout,*) '      Wave height frac. (used if nn_z0_met=2)       rn_frac_hs     = ', rn_frac_hs 
    969908         WRITE(numout,*) '      Stability functions                           nn_stab_func   = ', nn_stab_func 
    970909         WRITE(numout,*) '      Type of closure                               nn_clos        = ', nn_clos 
    971          WRITE(numout,*) '   Hard coded parameters' 
    972          WRITE(numout,*) '      Surface roughness (m)                         hsro          = ', hsro 
    973          WRITE(numout,*) '      Bottom roughness (m)                          hbro          = ', hbro 
     910         WRITE(numout,*) '      Surface roughness (m)                         rn_hsro        = ', rn_hsro 
     911         WRITE(numout,*) '      Bottom roughness (m) (nambfr namelist)        rn_bfrz0       = ', rn_bfrz0 
    974912      ENDIF 
    975913 
     
    978916 
    979917      !                                !* Check of some namelist values 
    980       IF( nn_tkebc_surf < 0 .OR. nn_tkebc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_tkebc_surf is 0 or 1' ) 
    981       IF( nn_psibc_surf < 0 .OR. nn_psibc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_psibc_surf is 0 or 1' ) 
    982       IF( nn_tkebc_bot  < 0 .OR. nn_tkebc_bot  > 1 ) CALL ctl_stop( 'bad flag: nn_tkebc_bot is 0 or 1' ) 
    983       IF( nn_psibc_bot  < 0 .OR. nn_psibc_bot  > 1 ) CALL ctl_stop( 'bad flag: nn_psibc_bot is 0 or 1' ) 
     918      IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_bc_surf is 0 or 1' ) 
     919      IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_bc_surf is 0 or 1' ) 
     920      IF( nn_z0_met < 0 .OR. nn_z0_met > 2 ) CALL ctl_stop( 'bad flag: nn_z0_met is 0, 1 or 2' ) 
    984921      IF( nn_stab_func  < 0 .OR. nn_stab_func  > 3 ) CALL ctl_stop( 'bad flag: nn_stab_func is 0, 1, 2 and 3' ) 
    985922      IF( nn_clos       < 0 .OR. nn_clos       > 3 ) CALL ctl_stop( 'bad flag: nn_clos is 0, 1, 2 or 3' ) 
     
    1001938         SELECT CASE ( nn_stab_func ) 
    1002939         CASE( 0, 1 )   ;   rpsi3m = 2.53_wp       ! G88 or KC stability functions 
    1003          CASE( 2 )      ;   rpsi3m = 2.38_wp       ! Canuto A stability functions 
     940         CASE( 2 )      ;   rpsi3m = 2.62_wp       ! Canuto A stability functions 
    1004941         CASE( 3 )      ;   rpsi3m = 2.38          ! Canuto B stability functions (caution : constant not identified) 
    1005942         END SELECT 
     
    1012949         rnn     = -1._wp 
    1013950         rsc_tke =  1._wp 
    1014          rsc_psi =  1.3_wp  ! Schmidt number for psi 
     951         rsc_psi =  1.2_wp  ! Schmidt number for psi 
    1015952         rpsi1   =  1.44_wp 
    1016953         rpsi3p  =  1._wp 
     
    11401077      !                                     ! See Eq. (13) of Carniel et al, OM, 30, 225-239, 2009 
    11411078      !                                     !  or Eq. (17) of Burchard, JPO, 31, 3133-3145, 2001 
    1142       IF( ln_sigpsi .AND. ln_crban ) THEN 
    1143          zcr = SQRT( 1.5_wp*rsc_tke ) * rcm_sf / vkarmn 
    1144          rsc_psi0 = vkarmn*vkarmn / ( rpsi2 * rcm_sf*rcm_sf )                       &  
    1145         &         * ( rnn*rnn - 4._wp/3._wp * zcr*rnn*rmm - 1._wp/3._wp * zcr*rnn   & 
    1146         &           + 2._wp/9._wp * rmm * zcr*zcr + 4._wp/9._wp * zcr*zcr * rmm*rmm )                                  
     1079      IF( ln_sigpsi ) THEN 
     1080         ra_sf = -1.5 ! Set kinetic energy slope, then deduce rsc_psi and rl_sf  
     1081         ! Verification: retrieve Burchard (2001) results by uncomenting the line below: 
     1082         ! Note that the results depend on the value of rn_cm_sf which is constant (=rc0) in his work 
     1083         ! ra_sf = -SQRT(2./3.*rc0**3./rn_cm_sf*rn_sc_tke)/vkarmn 
     1084         rsc_psi0 = rsc_tke/(24.*rpsi2)*(-1.+(4.*rnn + ra_sf*(1.+4.*rmm))**2./(ra_sf**2.)) 
    11471085      ELSE 
    11481086         rsc_psi0 = rsc_psi 
     
    11511089      !                                !* Shear free turbulence parameters 
    11521090      ! 
    1153       ra_sf  = -4._wp * rnn * SQRT( rsc_tke ) / ( (1._wp+4._wp*rmm) * SQRT( rsc_tke )   & 
    1154          &                                      - SQRT(rsc_tke + 24._wp*rsc_psi0*rpsi2 ) ) 
    1155       rl_sf  = rc0 * SQRT( rc0 / rcm_sf )                                                                   & 
    1156          &         * SQRT(  (  (1._wp + 4._wp*rmm + 8._wp*rmm*rmm) * rsc_tke                                & 
    1157          &                   + 12._wp * rsc_psi0 * rpsi2                                                    & 
    1158          &                   - (1._wp + 4._wp*rmm) * SQRT( rsc_tke*(rsc_tke+ 24._wp*rsc_psi0*rpsi2) )  )    & 
    1159          &                / ( 12._wp*rnn*rnn )                                                              ) 
     1091      ra_sf  = -4._wp*rnn*SQRT(rsc_tke) / ( (1._wp+4._wp*rmm)*SQRT(rsc_tke) & 
     1092               &                              - SQRT(rsc_tke + 24._wp*rsc_psi0*rpsi2 ) ) 
     1093 
     1094      IF ( rn_crban==0._wp ) THEN 
     1095         rl_sf = vkarmn 
     1096      ELSE 
     1097         rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp)*rsc_tke          & 
     1098                 &                                       + 12._wp * rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm) & 
     1099                 &                                                *SQRT(rsc_tke*(rsc_tke                 & 
     1100                 &                                                   + 24._wp*rsc_psi0*rpsi2)) )         & 
     1101                 &                                         /(12._wp*rnn**2.)                             & 
     1102                 &                                       ) 
     1103      ENDIF 
    11601104 
    11611105      ! 
     
    11871131      rc03  = rc02 * rc0 
    11881132      rc04  = rc03 * rc0 
    1189       rc03_sqrt2_galp = rc03 / SQRT(2._wp) / rn_clim_galp 
    1190       rsbc_mb   = 0.5_wp * (15.8_wp*rn_crban)**(2._wp/3._wp)               ! Surf. bound. cond. from Mellor and Blumberg 
    1191       rsbc_std  = 3.75_wp                                                  ! Surf. bound. cond. standard (prod=diss) 
    1192       rsbc_tke1 = (-rsc_tke*rn_crban/(rcm_sf*ra_sf*rl_sf))**(2._wp/3._wp)  ! k_eps = 53.  Dirichlet + Wave breaking  
    1193       rsbc_tke2 = 0.5_wp / rau0 
    1194       rsbc_tke3 = rdt * rn_crban                                                         ! Neumann + Wave breaking 
    1195       rsbc_zs   = rn_charn / grav                                                        ! Charnock formula 
    1196       rsbc_psi1 = rc0**rpp * rsbc_tke1**rmm * rl_sf**rnn                           ! Dirichlet + Wave breaking 
    1197       rsbc_psi2 = -0.5_wp * rdt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi                   ! Neumann + NO Wave breaking  
    1198       rsbc_psi3 = -0.5_wp * rdt * rc0**rpp * rl_sf**rnn / rsc_psi  * (rnn + rmm*ra_sf) ! Neumann + Wave breaking 
    1199       rfact_tke = -0.5_wp / rsc_tke * rdt               ! Cst used for the Diffusion term of tke 
    1200       rfact_psi = -0.5_wp / rsc_psi * rdt               ! Cst used for the Diffusion term of tke 
     1133      rsbc_tke1 = -3._wp/2._wp*rn_crban*ra_sf*rl_sf                      ! Dirichlet + Wave breaking 
     1134      rsbc_tke2 = rdt * rn_crban / rl_sf                                 ! Neumann + Wave breaking  
     1135      zcr = MAX(rsmall, rsbc_tke1**(1./(-ra_sf*3._wp/2._wp))-1._wp ) 
     1136      rtrans = 0.2_wp / zcr                                              ! Ad. inverse transition length between log and wave layer  
     1137      rsbc_zs1  = rn_charn/grav                                          ! Charnock formula for surface roughness 
     1138      rsbc_zs2  = rn_frac_hs / 0.85_wp / grav * 665._wp                  ! Rascle formula for surface roughness  
     1139      rsbc_psi1 = -0.5_wp * rdt * rc0**(rpp-2._wp*rmm) / rsc_psi 
     1140      rsbc_psi2 = -0.5_wp * rdt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi ! Neumann + NO Wave breaking  
     1141 
     1142      rfact_tke = -0.5_wp / rsc_tke * rdt                                ! Cst used for the Diffusion term of tke 
     1143      rfact_psi = -0.5_wp / rsc_psi * rdt                                ! Cst used for the Diffusion term of tke 
    12011144 
    12021145      !                                !* Wall proximity function 
     
    12571200               IF(lwp) WRITE(numout,*) ' ===>>>> : previous run without gls scheme, en and mxln computed by iterative loop' 
    12581201               en  (:,:,:) = rn_emin 
    1259                mxln(:,:,:) = 0.001         
     1202               mxln(:,:,:) = 0.05         
    12601203               avt_k (:,:,:) = avt (:,:,:) 
    12611204               avm_k (:,:,:) = avm (:,:,:) 
     
    12671210            IF(lwp) WRITE(numout,*) ' ===>>>> : Initialisation of en and mxln by background values' 
    12681211            en  (:,:,:) = rn_emin 
    1269             mxln(:,:,:) = 0.001        
     1212            mxln(:,:,:) = 0.05        
    12701213         ENDIF 
    12711214         ! 
     
    12731216         !                                   ! ------------------- 
    12741217         IF(lwp) WRITE(numout,*) '---- gls-rst ----' 
    1275          CALL iom_rstput( kt, nitrst, numrow, 'en'   , en     ) 
     1218         CALL iom_rstput( kt, nitrst, numrow, 'en'   , en     )  
    12761219         CALL iom_rstput( kt, nitrst, numrow, 'avt'  , avt_k  ) 
    12771220         CALL iom_rstput( kt, nitrst, numrow, 'avm'  , avm_k  ) 
    1278          CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu_k ) 
     1221         CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu_k )  
    12791222         CALL iom_rstput( kt, nitrst, numrow, 'avmv' , avmv_k ) 
    12801223         CALL iom_rstput( kt, nitrst, numrow, 'mxln' , mxln   ) 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfini.F90

    r5038 r5620  
    1414   !!---------------------------------------------------------------------- 
    1515   USE par_oce         ! mesh and scale factors 
    16    USE sbc_oce         ! surface module (only for nn_isf in the option compatibility test) 
    1716   USE ldftra_oce      ! ocean active tracers: lateral physics 
    1817   USE ldfdyn_oce      ! ocean dynamics lateral physics 
     
    118117      IF( ioptio == 0 .OR. ioptio > 1 .AND. .NOT. lk_esopa )   & 
    119118         &   CALL ctl_stop( ' one and only one vertical diffusion option has to be defined ' ) 
    120       IF( ( lk_zdfric .OR. lk_zdfgls .OR. lk_zdfkpp ) .AND. nn_isf .NE. 0 )   & 
     119      IF( ( lk_zdfric .OR. lk_zdfgls .OR. lk_zdfkpp ) .AND. ln_isfcav )   & 
    121120         &   CALL ctl_stop( ' only zdfcst and zdftke were tested with ice shelves cavities ' ) 
    122121      ! 
     
    125124      IF(lwp) WRITE(numout,*) '   convection :' 
    126125      ! 
    127       IF( ln_zdfnpc )   CALL ctl_stop( ' zdf_init: non penetrative convective scheme is not working',   & 
    128          &                                       ' set ln_zdfnpc to FALSE' ) 
     126#if defined key_top 
     127      IF( ln_zdfnpc )   CALL ctl_stop( ' zdf_init: npc scheme is not working with key_top' ) 
     128#endif 
    129129      ! 
    130130      ioptio = 0 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r5038 r5620  
    2626   !!                 !                                + cleaning of the parameters + bugs correction 
    2727   !!            3.3  !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase 
     28   !!            3.6  !  2014-11  (P. Mathiot) add ice shelf capability 
    2829   !!---------------------------------------------------------------------- 
    2930#if defined key_zdftke   ||   defined key_esopa 
     
    236237      zfact3 = 0.5_wp       * rn_ediss 
    237238      ! 
     239      ! 
    238240      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    239241      !                     !  Surface boundary condition on tke 
    240242      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     243      IF ( ln_isfcav ) THEN 
     244         DO jj = 2, jpjm1            ! en(mikt(ji,jj))   = rn_emin 
     245            DO ji = fs_2, fs_jpim1   ! vector opt. 
     246               en(ji,jj,mikt(ji,jj))=rn_emin * tmask(ji,jj,1) 
     247            END DO 
     248         END DO 
     249      END IF 
    241250      DO jj = 2, jpjm1            ! en(1)   = rn_ebb taum / rau0  (min value rn_emin0) 
    242251         DO ji = fs_2, fs_jpim1   ! vector opt. 
    243             IF (mikt(ji,jj) .GT. 1) THEN 
    244                en(ji,jj,mikt(ji,jj))=rn_emin 
    245             ELSE 
    246                en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
    247             END IF 
     252            en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
    248253         END DO 
    249254      END DO 
     
    301306         END DO 
    302307         zcof = 0.016 / SQRT( zrhoa * zcdrag ) 
     308!CDIR NOVERRCHK 
    303309         DO jk = 2, jpkm1         !* TKE Langmuir circulation source term added to en 
    304             DO jj = 2, jpjm1 
     310!CDIR NOVERRCHK 
     311            DO jj = 2, jpjm1 
     312!CDIR NOVERRCHK 
    305313               DO ji = fs_2, fs_jpim1   ! vector opt. 
    306314                  zus  = zcof * SQRT( taum(ji,jj) )           ! Stokes drift 
     
    309317                  zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 
    310318                  !                                           ! TKE Langmuir circulation source term 
    311                   en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * tmask(ji,jj,jk) 
     319                  en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    312320               END DO 
    313321            END DO 
     
    328336               avmu(ji,jj,jk) = avmu(ji,jj,jk) * ( un(ji,jj,jk-1) - un(ji,jj,jk) )   & 
    329337                  &                            * ( ub(ji,jj,jk-1) - ub(ji,jj,jk) )   &  
    330                   &           / (  fse3uw_n(ji,jj,jk)         & 
    331                   &              * fse3uw_b(ji,jj,jk) ) 
     338                  &                            / (  fse3uw_n(ji,jj,jk)               & 
     339                  &                              *  fse3uw_b(ji,jj,jk) ) 
    332340               avmv(ji,jj,jk) = avmv(ji,jj,jk) * ( vn(ji,jj,jk-1) - vn(ji,jj,jk) )   & 
    333341                  &                            * ( vb(ji,jj,jk-1) - vb(ji,jj,jk) )   & 
     
    338346      END DO 
    339347      ! 
    340       DO jj = 2, jpjm1 
    341          DO ji = fs_2, fs_jpim1   ! vector opt. 
    342             DO jk = mikt(ji,jj)+1, jpkm1           !* Matrix and right hand side in en 
     348      DO jk = 2, jpkm1           !* Matrix and right hand side in en 
     349         DO jj = 2, jpjm1 
     350            DO ji = fs_2, fs_jpim1   ! vector opt. 
    343351               zcof   = zfact1 * tmask(ji,jj,jk) 
    344352               zzd_up = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &  ! upper diagonal 
     
    357365               en(ji,jj,jk) = en(ji,jj,jk) + rdt * (  zesh2  -   avt(ji,jj,jk) * rn2(ji,jj,jk)    & 
    358366                  &                                 + zfact3 * dissl(ji,jj,jk) * en (ji,jj,jk)  ) & 
    359                   &                                 * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 
    360             END DO 
    361             !                          !* Matrix inversion from level 2 (tke prescribed at level 1) 
    362             DO jk = mikt(ji,jj)+2, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
     367                  &                                 * wmask(ji,jj,jk) 
     368            END DO 
     369         END DO 
     370      END DO 
     371      !                          !* Matrix inversion from level 2 (tke prescribed at level 1) 
     372      DO jk = 3, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
     373         DO jj = 2, jpjm1 
     374            DO ji = fs_2, fs_jpim1    ! vector opt. 
    363375               zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
    364376            END DO 
    365             ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    366             zd_lw(ji,jj,mikt(ji,jj)+1) = en(ji,jj,mikt(ji,jj)+1) - zd_lw(ji,jj,mikt(ji,jj)+1) * en(ji,jj,mikt(ji,jj))    ! Surface boudary conditions on tke 
    367             ! 
    368             DO jk = mikt(ji,jj)+2, jpkm1 
     377         END DO 
     378      END DO 
     379      ! 
     380      ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
     381      DO jj = 2, jpjm1 
     382         DO ji = fs_2, fs_jpim1   ! vector opt. 
     383            zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1)    ! Surface boudary conditions on tke 
     384         END DO 
     385      END DO 
     386      DO jk = 3, jpkm1 
     387         DO jj = 2, jpjm1 
     388            DO ji = fs_2, fs_jpim1    ! vector opt. 
    369389               zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) 
    370390            END DO 
    371             ! 
    372             ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
     391         END DO 
     392      END DO 
     393      ! 
     394      ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
     395      DO jj = 2, jpjm1 
     396         DO ji = fs_2, fs_jpim1   ! vector opt. 
    373397            en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 
    374             ! 
    375             DO jk = jpk-2, mikt(ji,jj)+1, -1 
     398         END DO 
     399      END DO 
     400      DO jk = jpk-2, 2, -1 
     401         DO jj = 2, jpjm1 
     402            DO ji = fs_2, fs_jpim1    ! vector opt. 
    376403               en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
    377404            END DO 
    378             ! 
    379             DO jk = mikt(ji,jj), jpkm1                             ! set the minimum value of tke 
    380                en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * tmask(ji,jj,jk) 
     405         END DO 
     406      END DO 
     407      DO jk = 2, jpkm1                             ! set the minimum value of tke 
     408         DO jj = 2, jpjm1 
     409            DO ji = fs_2, fs_jpim1   ! vector opt. 
     410               en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) 
    381411            END DO 
    382412         END DO 
     
    391421               DO ji = fs_2, fs_jpim1   ! vector opt. 
    392422                  en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
    393                      &                                 * ( 1._wp - fr_i(ji,jj) )  * tmask(ji,jj,jk) * tmask(ji,jj,1) 
     423                     &                                 * ( 1._wp - fr_i(ji,jj) )  * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    394424               END DO 
    395425            END DO 
     
    400430               jk = nmln(ji,jj) 
    401431               en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
    402                   &                                 * ( 1._wp - fr_i(ji,jj) )  * tmask(ji,jj,jk) * tmask(ji,jj,1) 
     432                  &                                 * ( 1._wp - fr_i(ji,jj) )  * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    403433            END DO 
    404434         END DO 
     
    416446                  zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add )  ! apply some modifications... 
    417447                  en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
    418                      &                        * ( 1._wp - fr_i(ji,jj) ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * tmask(ji,jj,1) 
     448                     &                        * ( 1._wp - fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    419449               END DO 
    420450            END DO 
     
    484514      !                     !* Buoyancy length scale: l=sqrt(2*e/n**2) 
    485515      ! 
     516      ! initialisation of interior minimum value (avoid a 2d loop with mikt) 
     517      zmxlm(:,:,:)  = rmxl_min     
     518      zmxld(:,:,:)  = rmxl_min 
     519      ! 
    486520      IF( ln_mxl0 ) THEN            ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rau0*g) 
    487521         DO jj = 2, jpjm1 
    488522            DO ji = fs_2, fs_jpim1 
    489                IF (mikt(ji,jj) .GT. 1) THEN 
    490                   zmxlm(ji,jj,mikt(ji,jj)) = rmxl_min 
    491                ELSE 
    492                   zraug = vkarmn * 2.e5_wp / ( rau0 * grav ) 
    493                   zmxlm(ji,jj,mikt(ji,jj)) = MAX( rn_mxl0, zraug * taum(ji,jj) ) 
    494                END IF 
     523               zraug = vkarmn * 2.e5_wp / ( rau0 * grav ) 
     524               zmxlm(ji,jj,1) = MAX( rn_mxl0, zraug * taum(ji,jj) * tmask(ji,jj,1) ) 
    495525            END DO 
    496526         END DO 
    497527      ELSE  
    498          DO jj = 2, jpjm1 
    499             DO ji = fs_2, fs_jpim1                         ! surface set to the minimum value 
    500                zmxlm(ji,jj,mikt(ji,jj)) = MAX( tmask(ji,jj,1) * rn_mxl0, rmxl_min) 
    501             END DO 
    502          END DO 
     528         zmxlm(:,:,1) = rn_mxl0 
    503529      ENDIF 
    504       zmxlm(:,:,jpk)  = rmxl_min     ! last level set to the interior minium value 
    505       ! 
    506 !CDIR NOVERRCHK 
    507       DO jj = 2, jpjm1 
    508 !CDIR NOVERRCHK 
    509          DO ji = fs_2, fs_jpim1   ! vector opt. 
    510             !CDIR NOVERRCHK 
    511             DO jk = mikt(ji,jj)+1, jpkm1              ! interior value : l=sqrt(2*e/n^2) 
     530      ! 
     531!CDIR NOVERRCHK 
     532      DO jk = 2, jpkm1              ! interior value : l=sqrt(2*e/n^2) 
     533!CDIR NOVERRCHK 
     534         DO jj = 2, jpjm1 
     535!CDIR NOVERRCHK 
     536            DO ji = fs_2, fs_jpim1   ! vector opt. 
    512537               zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 
    513                zmxlm(ji,jj,jk) = MAX(  rmxl_min,  SQRT( 2._wp * en(ji,jj,jk) / zrn2 )  ) 
    514             END DO 
    515             zmxld(ji,jj,mikt(ji,jj)) = zmxlm(ji,jj,mikt(ji,jj))   ! surface set to the minimum value  
     538               zmxlm(ji,jj,jk) = MAX(  rmxl_min,  SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) ) 
     539            END DO 
    516540         END DO 
    517541      END DO 
     
    519543      !                     !* Physical limits for the mixing length 
    520544      ! 
    521       zmxld(:,:, 1 ) = zmxlm(:,:,1)   ! surface set to the zmxlm   value 
     545      zmxld(:,:,1  ) = zmxlm(:,:,1)   ! surface set to the minimum value  
    522546      zmxld(:,:,jpk) = rmxl_min       ! last level  set to the minimum value 
    523547      ! 
    524548      SELECT CASE ( nn_mxl ) 
    525549      ! 
     550      ! where wmask = 0 set zmxlm == fse3w 
    526551      CASE ( 0 )           ! bounded by the distance to surface and bottom 
    527          DO jj = 2, jpjm1 
    528             DO ji = fs_2, fs_jpim1   ! vector opt. 
    529                DO jk = mikt(ji,jj)+1, jpkm1 
     552         DO jk = 2, jpkm1 
     553            DO jj = 2, jpjm1 
     554               DO ji = fs_2, fs_jpim1   ! vector opt. 
    530555                  zemxl = MIN( fsdepw(ji,jj,jk) - fsdepw(ji,jj,mikt(ji,jj)), zmxlm(ji,jj,jk),   & 
    531556                  &            fsdepw(ji,jj,mbkt(ji,jj)+1) - fsdepw(ji,jj,jk) ) 
    532                   zmxlm(ji,jj,jk) = zemxl 
    533                   zmxld(ji,jj,jk) = zemxl 
     557                  ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) 
     558                  zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN(zmxlm(ji,jj,jk),fse3w(ji,jj,jk)) * (1 - wmask(ji,jj,jk)) 
     559                  zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN(zmxlm(ji,jj,jk),fse3w(ji,jj,jk)) * (1 - wmask(ji,jj,jk)) 
    534560               END DO 
    535561            END DO 
     
    537563         ! 
    538564      CASE ( 1 )           ! bounded by the vertical scale factor 
    539          DO jj = 2, jpjm1 
    540             DO ji = fs_2, fs_jpim1   ! vector opt. 
    541                DO jk = mikt(ji,jj)+1, jpkm1 
     565         DO jk = 2, jpkm1 
     566            DO jj = 2, jpjm1 
     567               DO ji = fs_2, fs_jpim1   ! vector opt. 
    542568                  zemxl = MIN( fse3w(ji,jj,jk), zmxlm(ji,jj,jk) ) 
    543569                  zmxlm(ji,jj,jk) = zemxl 
     
    548574         ! 
    549575      CASE ( 2 )           ! |dk[xml]| bounded by e3t : 
    550          DO jj = 2, jpjm1 
    551             DO ji = fs_2, fs_jpim1   ! vector opt. 
    552                DO jk = mikt(ji,jj)+1, jpkm1         ! from the surface to the bottom : 
     576         DO jk = 2, jpkm1         ! from the surface to the bottom : 
     577            DO jj = 2, jpjm1 
     578               DO ji = fs_2, fs_jpim1   ! vector opt. 
    553579                  zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + fse3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 
    554580               END DO 
    555                DO jk = jpkm1, mikt(ji,jj)+1, -1     ! from the bottom to the surface : 
     581            END DO 
     582         END DO 
     583         DO jk = jpkm1, 2, -1     ! from the bottom to the surface : 
     584            DO jj = 2, jpjm1 
     585               DO ji = fs_2, fs_jpim1   ! vector opt. 
    556586                  zemxl = MIN( zmxlm(ji,jj,jk+1) + fse3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 
    557587                  zmxlm(ji,jj,jk) = zemxl 
     
    562592         ! 
    563593      CASE ( 3 )           ! lup and ldown, |dk[xml]| bounded by e3t : 
    564          DO jj = 2, jpjm1 
    565             DO ji = fs_2, fs_jpim1   ! vector opt. 
    566                DO jk = mikt(ji,jj)+1, jpkm1         ! from the surface to the bottom : lup 
     594         DO jk = 2, jpkm1         ! from the surface to the bottom : lup 
     595            DO jj = 2, jpjm1 
     596               DO ji = fs_2, fs_jpim1   ! vector opt. 
    567597                  zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + fse3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 
    568598               END DO 
    569                DO jk = jpkm1, mikt(ji,jj)+1, -1     ! from the bottom to the surface : ldown 
     599            END DO 
     600         END DO 
     601         DO jk = jpkm1, 2, -1     ! from the bottom to the surface : ldown 
     602            DO jj = 2, jpjm1 
     603               DO ji = fs_2, fs_jpim1   ! vector opt. 
    570604                  zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + fse3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 
    571605               END DO 
     
    604638               zsqen = SQRT( en(ji,jj,jk) ) 
    605639               zav   = rn_ediff * zmxlm(ji,jj,jk) * zsqen 
    606                avm  (ji,jj,jk) = MAX( zav,                  avmb(jk) ) * tmask(ji,jj,jk) 
    607                avt  (ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * tmask(ji,jj,jk) 
     640               avm  (ji,jj,jk) = MAX( zav,                  avmb(jk) ) * wmask(ji,jj,jk) 
     641               avt  (ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 
    608642               dissl(ji,jj,jk) = zsqen / zmxld(ji,jj,jk) 
    609643            END DO 
     
    612646      CALL lbc_lnk( avm, 'W', 1. )      ! Lateral boundary conditions (sign unchanged) 
    613647      ! 
    614       DO jj = 2, jpjm1 
    615          DO ji = fs_2, fs_jpim1   ! vector opt. 
    616             DO jk = miku(ji,jj)+1, jpkm1            !* vertical eddy viscosity at u- and v-points 
    617                avmu(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji+1,jj  ,jk) ) * umask(ji,jj,jk) 
    618             END DO 
    619             DO jk = mikv(ji,jj)+1, jpkm1 
    620                avmv(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji  ,jj+1,jk) ) * vmask(ji,jj,jk) 
     648      DO jk = 2, jpkm1            !* vertical eddy viscosity at wu- and wv-points 
     649         DO jj = 2, jpjm1 
     650            DO ji = fs_2, fs_jpim1   ! vector opt. 
     651               avmu(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji+1,jj  ,jk) ) * wumask(ji,jj,jk) 
     652               avmv(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji  ,jj+1,jk) ) * wvmask(ji,jj,jk) 
    621653            END DO 
    622654         END DO 
     
    625657      ! 
    626658      IF( nn_pdl == 1 ) THEN      !* Prandtl number case: update avt 
    627          DO jj = 2, jpjm1 
    628             DO ji = fs_2, fs_jpim1   ! vector opt. 
    629                DO jk = mikt(ji,jj)+1, jpkm1 
     659         DO jk = 2, jpkm1 
     660            DO jj = 2, jpjm1 
     661               DO ji = fs_2, fs_jpim1   ! vector opt. 
    630662                  zcoef = avm(ji,jj,jk) * 2._wp * fse3w(ji,jj,jk) * fse3w(ji,jj,jk) 
    631663                  !                                          ! shear 
     
    639671!!gm and even better with the use of the "true" ri_crit=0.22222...  (this change the results!) 
    640672!!gm              zpdlr = MAX(  0.1_wp,  ri_crit / MAX( ri_crit , zri )  ) 
    641                   avt(ji,jj,jk)   = MAX( zpdlr * avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * tmask(ji,jj,jk) 
     673                  avt(ji,jj,jk)   = MAX( zpdlr * avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 
    642674# if defined key_c1d 
    643                   e_pdl(ji,jj,jk) = zpdlr * tmask(ji,jj,jk)  ! c1d configuration : save masked Prandlt number 
    644                   e_ric(ji,jj,jk) = zri   * tmask(ji,jj,jk)  ! c1d config. : save Ri 
     675                  e_pdl(ji,jj,jk) = zpdlr * wmask(ji,jj,jk)  ! c1d configuration : save masked Prandlt number 
     676                  e_ric(ji,jj,jk) = zri   * wmask(ji,jj,jk)  ! c1d config. : save Ri 
    645677# endif 
    646678              END DO 
     
    729761      IF( nn_pdl  < 0   .OR.  nn_pdl  > 1 )   CALL ctl_stop( 'bad flag: nn_pdl is  0 or 1    ' ) 
    730762      IF( nn_htau < 0   .OR.  nn_htau > 1 )   CALL ctl_stop( 'bad flag: nn_htau is 0, 1 or 2 ' ) 
    731       IF( nn_etau == 3 .AND. .NOT. lk_cpl )   CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' ) 
     763      IF( nn_etau == 3 .AND. .NOT. ln_cpl )   CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' ) 
    732764 
    733765      IF( ln_mxl0 ) THEN 
     
    749781      !                               !* set vertical eddy coef. to the background value 
    750782      DO jk = 1, jpk 
    751          avt (:,:,jk) = avtb(jk) * tmask(:,:,jk) 
    752          avm (:,:,jk) = avmb(jk) * tmask(:,:,jk) 
    753          avmu(:,:,jk) = avmb(jk) * umask(:,:,jk) 
    754          avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk) 
     783         avt (:,:,jk) = avtb(jk) * wmask (:,:,jk) 
     784         avm (:,:,jk) = avmb(jk) * wmask (:,:,jk) 
     785         avmu(:,:,jk) = avmb(jk) * wumask(:,:,jk) 
     786         avmv(:,:,jk) = avmb(jk) * wvmask(:,:,jk) 
    755787      END DO 
    756788      dissl(:,:,:) = 1.e-12_wp 
     
    803835              en (:,:,:) = rn_emin * tmask(:,:,:) 
    804836              CALL tke_avn                               ! recompute avt, avm, avmu, avmv and dissl (approximation) 
     837              ! 
     838              avt_k (:,:,:) = avt (:,:,:) 
     839              avm_k (:,:,:) = avm (:,:,:) 
     840              avmu_k(:,:,:) = avmu(:,:,:) 
     841              avmv_k(:,:,:) = avmv(:,:,:) 
     842              ! 
    805843              DO jit = nit000 + 1, nit000 + 10   ;   CALL zdf_tke( jit )   ;   END DO 
    806844           ENDIF 
     
    808846           en(:,:,:) = rn_emin * tmask(:,:,:) 
    809847           DO jk = 1, jpk                           ! set the Kz to the background value 
    810               avt (:,:,jk) = avtb(jk) * tmask(:,:,jk) 
    811               avm (:,:,jk) = avmb(jk) * tmask(:,:,jk) 
    812               avmu(:,:,jk) = avmb(jk) * umask(:,:,jk) 
    813               avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk) 
     848              avt (:,:,jk) = avtb(jk) * wmask (:,:,jk) 
     849              avm (:,:,jk) = avmb(jk) * wmask (:,:,jk) 
     850              avmu(:,:,jk) = avmb(jk) * wumask(:,:,jk) 
     851              avmv(:,:,jk) = avmb(jk) * wvmask(:,:,jk) 
    814852           END DO 
    815853        ENDIF 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90

    r5038 r5620  
    126126      zkz(:,:) = 0.e0               !* Associated potential energy consummed over the whole water column 
    127127      DO jk = 2, jpkm1 
    128          zkz(:,:) = zkz(:,:) + fse3w(:,:,jk) * MAX( 0.e0, rn2(:,:,jk) ) * rau0 * zav_tide(:,:,jk)* tmask(:,:,jk) * tmask(:,:,jk-1) 
     128         zkz(:,:) = zkz(:,:) + fse3w(:,:,jk) * MAX( 0.e0, rn2(:,:,jk) ) * rau0 * zav_tide(:,:,jk) * wmask(:,:,jk) 
    129129      END DO 
    130130 
     
    135135      END DO 
    136136 
    137       DO jj = 1, jpj                !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 
    138          DO ji = 1, jpi 
    139             DO jk = mikt(ji,jj)+1, jpkm1     !* Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zav_tide bound by 300 cm2/s 
    140                zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. )   !kz max = 300 cm2/s 
     137      DO jk = 2, jpkm1     !* Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zav_tide bound by 300 cm2/s 
     138         DO jj = 1, jpj                !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 
     139            DO ji = 1, jpi 
     140               zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. ) * wmask(ji,jj,jk)  !kz max = 300 cm2/s 
    141141            END DO 
    142142         END DO 
     
    166166      !                          !   Update  mixing coefs  !                           
    167167      !                          ! ----------------------- ! 
    168       DO jj = 1, jpj                !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 
    169          DO ji = 1, jpi 
    170             DO jk = mikt(ji,jj)+1, jpkm1              !* update momentum & tracer diffusivity with tidal mixing 
    171                avt(ji,jj,jk) = avt(ji,jj,jk) + zav_tide(ji,jj,jk) 
    172                avm(ji,jj,jk) = avm(ji,jj,jk) + zav_tide(ji,jj,jk) 
     168      DO jk = 2, jpkm1              !* update momentum & tracer diffusivity with tidal mixing 
     169         DO jj = 1, jpj                !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 
     170            DO ji = 1, jpi 
     171               avt(ji,jj,jk) = avt(ji,jj,jk) + zav_tide(ji,jj,jk) * wmask(ji,jj,jk) 
     172               avm(ji,jj,jk) = avm(ji,jj,jk) + zav_tide(ji,jj,jk) * wmask(ji,jj,jk) 
    173173            END DO 
    174174         END DO 
    175175      END DO 
    176176       
    177       DO jj = 2, jpjm1 
    178          DO ji = fs_2, fs_jpim1  ! vector opt. 
    179             DO jk = mikt(ji,jj)+1, jpkm1              !* update momentum & tracer diffusivity with tidal mixing 
    180                avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji+1,jj  ,jk) ) * umask(ji,jj,jk) 
    181                avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji  ,jj+1,jk) ) * vmask(ji,jj,jk) 
     177      DO jk = 2, jpkm1              !* update momentum & tracer diffusivity with tidal mixing 
     178         DO jj = 2, jpjm1 
     179            DO ji = fs_2, fs_jpim1  ! vector opt. 
     180               avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji+1,jj  ,jk) ) * wumask(ji,jj,jk) 
     181               avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji  ,jj+1,jk) ) * wvmask(ji,jj,jk) 
    182182            END DO 
    183183         END DO 
     
    457457         ztpc = 0.e0 
    458458         zpc(:,:,:) = MAX(rn_n2min,rn2(:,:,:)) * zav_tide(:,:,:) 
    459          DO jj = 1, jpj 
    460             DO ji = 1, jpi 
    461                DO jk= mikt(ji,jj)+1, jpkm1 
    462                   ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
     459         DO jk= 2, jpkm1 
     460            DO jj = 1, jpj 
     461               DO ji = 1, jpi 
     462                  ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 
    463463               END DO 
    464464            END DO 
     
    473473         zav_tide(:,:,:) = MIN( zav_tide(:,:,:), 60.e-4 )    
    474474         zkz(:,:) = 0.e0 
    475          DO jj = 1, jpj 
    476             DO ji = 1, jpi 
    477                DO jk = mikt(ji,jj)+1, jpkm1 
    478                zkz(ji,jj) = zkz(ji,jj) + fse3w(ji,jj,jk) * MAX( 0.e0, rn2(ji,jj,jk) ) * rau0 * zav_tide(ji,jj,jk)* tmask(ji,jj,jk) 
     475         DO jk = 2, jpkm1 
     476            DO jj = 1, jpj 
     477               DO ji = 1, jpi 
     478                  zkz(ji,jj) = zkz(ji,jj) + fse3w(ji,jj,jk) * MAX(0.e0, rn2(ji,jj,jk)) * rau0 * zav_tide(ji,jj,jk) * wmask(ji,jj,jk) 
    479479               END DO 
    480480            END DO 
     
    498498         WRITE(numout,*) '          Min de zkz ', ztpc, ' Max = ', maxval(zkz(:,:) ) 
    499499 
    500          DO jj = 1, jpj 
    501             DO ji = 1, jpi 
    502                DO jk = mikt(ji,jj)+1, jpkm1 
    503                   zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. )   !kz max = 300 cm2/s 
     500         DO jk = 2, jpkm1 
     501            DO jj = 1, jpj 
     502               DO ji = 1, jpi 
     503                  zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. ) * wmask(ji,jj,jk)  !kz max = 300 cm2/s 
    504504               END DO 
    505505            END DO 
     
    510510            DO jj = 1, jpj 
    511511               DO ji = 1, jpi 
    512                   ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
     512                  ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 
    513513               END DO 
    514514            END DO 
     
    519519         DO jk = 1, jpk 
    520520            ze_z =                  SUM( e1t(:,:) * e2t(:,:) * zav_tide(:,:,jk)     * tmask_i(:,:) )   & 
    521                &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * tmask (:,:,jk) * tmask_i(:,:) ) ) 
     521               &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) 
    522522            ztpc = 1.E50 
    523523            DO jj = 1, jpj 
     
    540540            END DO 
    541541            ze_z =                  SUM( e1t(:,:) * e2t(:,:) * zkz(:,:)     * tmask_i(:,:) )   & 
    542                &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * tmask (:,:,jk) * tmask_i(:,:) ) ) 
     542               &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) 
    543543            WRITE(numout,*) '                jk= ', jk,'   ', ze_z * 1.e4,' cm2/s' 
    544544         END DO 
     
    546546            zkz(:,:) = az_tmx(:,:,jk) /rn_n2min 
    547547            ze_z =                  SUM( e1t(:,:) * e2t(:,:) * zkz(:,:)     * tmask_i(:,:) )   & 
    548                &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * tmask (:,:,jk) * tmask_i(:,:) ) ) 
     548               &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) 
    549549            WRITE(numout,*)  
    550550            WRITE(numout,*) '          N2 min - jk= ', jk,'   ', ze_z * 1.e4,' cm2/s min= ',MINVAL(zkz)*1.e4,   & 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r5038 r5620  
    8282   USE crsini          ! initialise grid coarsening utility 
    8383   USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges  
     84   USE sbc_oce, ONLY: lk_oasis 
     85   USE stopar 
     86   USE stopts 
    8487 
    8588   IMPLICIT NONE 
     
    184187      ! 
    185188#if defined key_agrif 
    186       CALL Agrif_ParentGrid_To_ChildGrid() 
    187       IF( lk_diaobs ) CALL dia_obs_wri 
    188       IF( nn_timing == 1 )   CALL timing_finalize 
    189       CALL Agrif_ChildGrid_To_ParentGrid() 
     189      IF ( Agrif_Level() < Agrif_MaxLevel() ) THEN  
     190         CALL Agrif_ParentGrid_To_ChildGrid() 
     191         IF( lk_diaobs ) CALL dia_obs_wri 
     192         IF( nn_timing == 1 )   CALL timing_finalize 
     193         CALL Agrif_ChildGrid_To_ParentGrid() 
     194      ENDIF 
    190195#endif 
    191196      IF( nn_timing == 1 )   CALL timing_finalize 
     
    195200#if defined key_iomput 
    196201      CALL xios_finalize                ! end mpp communications with xios 
    197       IF( lk_cpl ) CALL cpl_finalize    ! end coupling and mpp communications with OASIS 
     202      IF( lk_oasis ) CALL cpl_finalize    ! end coupling and mpp communications with OASIS 
    198203#else 
    199       IF( lk_cpl ) THEN  
     204      IF( lk_oasis ) THEN  
    200205         CALL cpl_finalize              ! end coupling and mpp communications with OASIS 
    201206      ELSE 
     
    222227         &             nn_bench, nn_timing 
    223228      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & 
    224          &             jpizoom, jpjzoom, jperio 
     229         &             jpizoom, jpjzoom, jperio, ln_use_jattr 
    225230      !!---------------------------------------------------------------------- 
    226231      ! 
    227232      cltxt = '' 
     233      cxios_context = 'nemo' 
    228234      ! 
    229235      !                             ! Open reference namelist and configuration namelist files 
     
    261267      nperio  = 0 
    262268      jperio  = 0 
     269      ln_use_jattr = .false. 
    263270   ENDIF 
    264271#endif 
     
    271278#if defined key_iomput 
    272279      IF( Agrif_Root() ) THEN 
    273          IF( lk_cpl ) THEN 
    274             CALL cpl_init( ilocal_comm )                               ! nemo local communicator given by oasis 
    275             CALL xios_initialize( "oceanx",local_comm=ilocal_comm )    ! send nemo communicator to xios 
     280         IF( lk_oasis ) THEN 
     281            CALL cpl_init( "oceanx", ilocal_comm )                     ! nemo local communicator given by oasis 
     282            CALL xios_initialize( "not used",local_comm=ilocal_comm )    ! send nemo communicator to xios 
    276283         ELSE 
    277             CALL  xios_initialize( "nemo",return_comm=ilocal_comm )    ! nemo local communicator given by xios 
     284            CALL  xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )    ! nemo local communicator given by xios 
    278285         ENDIF 
    279286      ENDIF 
    280       narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection 
     287      ! Nodes selection (control print return in cltxt) 
     288      narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 
    281289#else 
    282       IF( lk_cpl ) THEN 
     290      IF( lk_oasis ) THEN 
    283291         IF( Agrif_Root() ) THEN 
    284             CALL cpl_init( ilocal_comm )                       ! nemo local communicator given by oasis 
     292            CALL cpl_init( "oceanx", ilocal_comm )                      ! nemo local communicator given by oasis 
    285293         ENDIF 
    286          narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection (control print return in cltxt) 
     294         ! Nodes selection (control print return in cltxt) 
     295         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 
    287296      ELSE 
    288297         ilocal_comm = 0 
    289          narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop )                ! Nodes selection (control print return in cltxt) 
     298         ! Nodes selection (control print return in cltxt) 
     299         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop ) 
    290300      ENDIF 
    291301#endif 
     
    341351         WRITE(numout,*) '                       NEMO team' 
    342352         WRITE(numout,*) '            Ocean General Circulation Model' 
    343          WRITE(numout,*) '                  version 3.4  (2011) ' 
     353         WRITE(numout,*) '                  version 3.6  (2015) ' 
    344354         WRITE(numout,*) 
    345355         WRITE(numout,*) 
     
    383393      IF( lk_tide       )   CALL    tide_init( nit000 )    ! Initialisation of the tidal harmonics 
    384394 
     395                            CALL     sbc_init   ! Forcings : surface module (clem: moved here for bdy purpose) 
     396 
    385397      IF( lk_bdy        )   CALL     bdy_init   ! Open boundaries initialisation 
    386398      IF( lk_bdy        )   CALL bdy_dta_init   ! Open boundaries initialisation of external data arrays 
     
    389401 
    390402                            CALL dyn_nept_init  ! simplified form of Neptune effect 
    391  
    392403      !      
    393404      IF( ln_crs        )   CALL     crs_init   ! Domain initialization of coarsened grid 
    394405      ! 
    395406                                ! Ocean physics 
    396                             CALL     sbc_init   ! Forcings : surface module 
    397407      !                                         ! Vertical physics 
    398408                            CALL     zdf_init      ! namelist read 
     
    431441      IF( nn_cla == 1 .AND. cp_cfg == 'orca' .AND. jp_cfg == 2 )   CALL cla_init       ! Cross Land Advection 
    432442                            CALL icb_init( rdt, nit000)   ! initialise icebergs instance 
     443                            CALL sto_par_init   ! Stochastic parametrization 
     444      IF( ln_sto_eos     )  CALL sto_pts_init   ! RRandom T/S fluctuations 
    433445      
    434446#if defined key_top 
     
    506518         WRITE(numout,*) '      left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom 
    507519         WRITE(numout,*) '      lateral cond. type (between 0 and 6) jperio = ', jperio    
     520         WRITE(numout,*) '      use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 
    508521      ENDIF 
    509522      !                             ! Parameter control 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/par_oce.F90

    r5038 r5620  
    5353   !                                       !  = 6 cyclic East-West AND North fold F-point pivot 
    5454 
     55   ! Input file read offset 
     56   LOGICAL       ::   ln_use_jattr     !: Use file global attribute: open_ocean_jstart to determine start j-row  
     57                                           ! when reading input from those netcdf files that have the  
     58                                           ! attribute defined. This is designed to enable input files associated  
     59                                           ! with the extended grids used in the under ice shelf configurations to  
     60                                           ! be used without redundant rows when the ice shelves are not in use. 
     61 
    5562   !!  Values set to pp_not_used indicates that this parameter is not used in THIS config. 
    5663   !!  Values set to pp_to_be_computed  indicates that variables will be computed in domzgr 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/step.F90

    r5038 r5620  
    8383      IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. 
    8484# if defined key_iomput 
    85       IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( "nemo" ) 
     85      IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( cxios_context ) 
    8686# endif 
    8787#endif 
    8888                             indic = 0           ! reset to no error condition 
    8989      IF( kstp == nit000 ) THEN 
    90                       CALL iom_init( "nemo" )      ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
    91          IF( ln_crs ) CALL iom_init( "nemo_crs" )  ! initialize context for coarse grid 
     90         ! must be done after nemo_init for AGRIF+XIOS+OASIS 
     91                      CALL iom_init(      cxios_context          )  ! iom_put initialization 
     92         IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" )  ! initialize context for coarse grid 
    9293      ENDIF 
    9394 
    9495      IF( kstp /= nit000 )   CALL day( kstp )         ! Calendar (day was already called at nit000 in day_init) 
    95                              CALL iom_setkt( kstp - nit000 + 1, "nemo"     )   ! say to iom that we are at time step kstp 
    96       IF( ln_crs     )       CALL iom_setkt( kstp - nit000 + 1, "nemo_crs" )   ! say to iom that we are at time step kstp 
     96                             CALL iom_setkt( kstp - nit000 + 1,      cxios_context          )   ! tell iom we are at time step kstp 
     97      IF( ln_crs     )       CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" )   ! tell iom we are at time step kstp 
    9798 
    9899      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     
    100101      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    101102      IF( lk_tide    )   CALL sbc_tide( kstp ) 
    102       IF( lk_bdy     )   CALL bdy_dta ( kstp, time_offset=+1 )   ! update dynamic & tracer data at open boundaries 
    103  
     103      IF( lk_bdy     )  THEN 
     104         IF( ln_apr_dyn) CALL sbc_apr( kstp )   ! bdy_dta needs ssh_ib  
     105                         CALL bdy_dta ( kstp, time_offset=+1 )   ! update dynamic & tracer data at open boundaries 
     106      ENDIF 
    104107                         CALL sbc    ( kstp )         ! Sea Boundary Condition (including sea-ice) 
    105108                                                      ! clem: moved here for bdy ice purpose 
     109      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     110      ! Update stochastic parameters and random T/S fluctuations 
     111      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     112                        CALL sto_par( kstp )          ! Stochastic parameters 
    106113 
    107114      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     
    122129      IF( lk_zdfkpp  )   CALL zdf_kpp( kstp )            ! KPP closure scheme for Kz 
    123130      IF( lk_zdfcst  ) THEN                              ! Constant Kz (reset avt, avm[uv] to the background value) 
    124          avt (:,:,:) = rn_avt0 * tmask(:,:,:) 
    125          avmu(:,:,:) = rn_avm0 * umask(:,:,:) 
    126          avmv(:,:,:) = rn_avm0 * vmask(:,:,:) 
     131         avt (:,:,:) = rn_avt0 * wmask (:,:,:) 
     132         avmu(:,:,:) = rn_avm0 * wumask(:,:,:) 
     133         avmv(:,:,:) = rn_avm0 * wvmask(:,:,:) 
    127134      ENDIF 
    128135      IF( ln_rnf_mouth ) THEN                         ! increase diffusivity at rivers mouths 
     
    145152      ! 
    146153      IF( lk_ldfslp ) THEN                            ! slope of lateral mixing 
    147                          CALL eos( tsb, rhd, gdept_0(:,:,:) )             ! before in situ density 
    148          IF( ln_zps )    CALL zps_hde( kstp, jpts, tsb, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    149             &                                      rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   &             ! 
    150             &                               gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     154         IF(ln_sto_eos ) CALL sto_pts( tsn )          ! Random T/S fluctuations 
     155                         CALL eos( tsb, rhd, gdept_0(:,:,:) )               ! before in situ density 
     156         IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
     157            &            CALL zps_hde    ( kstp, jpts, tsb, gtsu, gtsv,  &  ! Partial steps: before horizontal gradient 
     158            &                                          rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     159         IF( ln_zps .AND.       ln_isfcav)                               & 
     160            &            CALL zps_hde_isf( kstp, jpts, tsb, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     161            &                                          rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     162            &                                   gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the first ocean level 
    151163         IF( ln_traldf_grif ) THEN                           ! before slope for Griffies operator 
    152164                         CALL ldf_slp_grif( kstp ) 
     
    158170      IF( lk_traldf_eiv )   CALL ldf_eiv( kstp )      ! eddy induced velocity coefficient 
    159171#endif 
    160 #if defined key_traldf_c3d && key_traldf_smag 
     172#if defined key_traldf_c3d && defined key_traldf_smag 
    161173                          CALL ldf_tra_smag( kstp )      ! eddy induced velocity coefficient 
    162174#  endif 
    163 #if defined key_dynldf_c3d && key_dynldf_smag 
     175#if defined key_dynldf_c3d && defined key_dynldf_smag 
    164176                          CALL ldf_dyn_smag( kstp )      ! eddy induced velocity coefficient 
    165177#  endif 
     
    176188          ! Note that the computation of vertical velocity above, hence "after" sea level 
    177189          ! is necessary to compute momentum advection for the rhs of barotropic loop: 
     190            IF(ln_sto_eos ) CALL sto_pts( tsn )                             ! Random T/S fluctuations 
    178191                            CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 
    179             IF( ln_zps )    CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    180                &                                      rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   &             ! 
    181                &                               gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     192            IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
     193               &            CALL zps_hde    ( kstp, jpts, tsn, gtsu, gtsv,  &    ! Partial steps: before horizontal gradient 
     194               &                                          rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     195            IF( ln_zps .AND.       ln_isfcav)                               & 
     196               &            CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     197               &                                          rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     198               &                                   gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
    182199 
    183200                                  ua(:,:,:) = 0.e0             ! set dynamics trends to zero 
     
    208225      ! diagnostics and outputs             (ua, va, tsa used as workspace) 
    209226      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    210       IF( lk_floats  )   CALL flo_stp( kstp )         ! drifting Floats 
    211       IF( lk_diahth  )   CALL dia_hth( kstp )         ! Thermocline depth (20 degres isotherm depth) 
    212       IF( .NOT. lk_cpl ) CALL dia_fwb( kstp )         ! Fresh water budget diagnostics 
    213       IF( ln_diaptr  )   CALL dia_ptr( kstp )         ! Poleward TRansports diagnostics 
    214       IF( lk_diadct  )   CALL dia_dct( kstp )         ! Transports 
    215       IF( lk_diaar5  )   CALL dia_ar5( kstp )         ! ar5 diag 
    216       IF( lk_diaharm )   CALL dia_harm( kstp )        ! Tidal harmonic analysis 
    217                          CALL dia_wri( kstp )         ! ocean model: outputs 
    218       ! 
    219       IF( ln_crs     )   CALL crs_fld( kstp )         ! ocean model: online field coarsening & output 
    220  
     227      IF( lk_floats  )      CALL flo_stp( kstp )         ! drifting Floats 
     228      IF( lk_diahth  )      CALL dia_hth( kstp )         ! Thermocline depth (20 degres isotherm depth) 
     229      IF( .NOT. ln_cpl )    CALL dia_fwb( kstp )         ! Fresh water budget diagnostics 
     230      IF( lk_diadct  )      CALL dia_dct( kstp )         ! Transports 
     231      IF( lk_diaar5  )      CALL dia_ar5( kstp )         ! ar5 diag 
     232      IF( lk_diaharm )      CALL dia_harm( kstp )        ! Tidal harmonic analysis 
     233                            CALL dia_wri( kstp )         ! ocean model: outputs 
     234      ! 
     235      IF( ln_crs     )      CALL crs_fld( kstp )         ! ocean model: online field coarsening & output 
    221236 
    222237#if defined key_top 
     
    244259      IF( lk_zdfkpp      )   CALL tra_kpp    ( kstp )       ! KPP non-local tracer fluxes 
    245260                             CALL tra_ldf    ( kstp )       ! lateral mixing 
     261 
     262      IF( ln_diaptr      )   CALL dia_ptr                   ! Poleward adv/ldf TRansports diagnostics 
     263 
    246264#if defined key_agrif 
    247265      IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_tra          ! tracers sponge 
     
    252270         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    253271                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
     272            IF( ln_sto_eos ) CALL sto_pts( tsn )                 ! Random T/S fluctuations 
    254273                             CALL eos    ( tsa, rhd, rhop, fsdept_n(:,:,:) )  ! Time-filtered in situ density for hpg computation 
    255          IF( ln_zps      )   CALL zps_hde( kstp, jpts, tsa, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    256             &                                      rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   &             ! 
    257             &                               gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     274            IF( ln_zps .AND. .NOT. ln_isfcav)                                & 
     275               &             CALL zps_hde    ( kstp, jpts, tsa, gtsu, gtsv,  &    ! Partial steps: before horizontal gradient 
     276               &                                           rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     277            IF( ln_zps .AND.       ln_isfcav)                                & 
     278               &             CALL zps_hde_isf( kstp, jpts, tsa, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     279               &                                           rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     280               &                                    gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
    258281      ELSE                                                  ! centered hpg  (eos then time stepping) 
    259282         IF ( .NOT. lk_dynspg_ts ) THEN                     ! eos already called in time-split case 
     283            IF( ln_sto_eos ) CALL sto_pts( tsn )    ! Random T/S fluctuations 
    260284                             CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) )  ! now in situ density for hpg computation 
    261          IF( ln_zps      )   CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    262          &                                      rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   &             ! 
    263          &                               gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     285         IF( ln_zps .AND. .NOT. ln_isfcav)                                   & 
     286               &             CALL zps_hde    ( kstp, jpts, tsn, gtsu, gtsv,  &    ! Partial steps: before horizontal gradient 
     287               &                                           rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     288         IF( ln_zps .AND.       ln_isfcav)                                   &  
     289               &             CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     290               &                                           rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     291               &                                    gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
    264292         ENDIF 
    265293         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
     
    322350                 CALL iom_close( numror )     ! close input  ocean restart file 
    323351         IF(lwm) CALL FLUSH    ( numond )     ! flush output namelist oce 
    324          IF( lwm.AND.numoni /= -1 ) CALL FLUSH    ( numoni )     ! flush output namelist ice     
     352         IF( lwm.AND.numoni /= -1 ) CALL FLUSH    ( numoni )     ! flush output namelist ice 
    325353      ENDIF 
    326354      IF( lrst_oce         )   CALL rst_write    ( kstp )   ! write output ocean restart file 
     
    329357      ! Coupled mode 
    330358      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    331       IF( lk_cpl           )   CALL sbc_cpl_snd( kstp )     ! coupled mode : field exchanges 
     359      IF( lk_oasis         )   CALL sbc_cpl_snd( kstp )     ! coupled mode : field exchanges 
    332360      ! 
    333361#if defined key_iomput 
    334362      IF( kstp == nitend .OR. indic < 0 ) THEN  
    335                       CALL iom_context_finalize( "nemo"     ) ! needed for XIOS+AGRIF 
    336          IF( ln_crs ) CALL iom_context_finalize( "nemo_crs" ) !  
     363                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
     364         IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) !  
    337365      ENDIF 
    338366#endif 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r5038 r5620  
    2727   USE sbc_oce          ! surface boundary condition: ocean 
    2828   USE sbctide          ! Tide initialisation 
     29   USE sbcapr           ! surface boundary condition: ssh_ib required by bdydta  
    2930 
    3031   USE traqsr           ! solar radiation penetration      (tra_qsr routine) 
     
    5354 
    5455   USE dynnxt           ! time-stepping                    (dyn_nxt routine) 
     56 
     57   USE stopar           ! Stochastic parametrization       (sto_par routine) 
     58   USE stopts  
    5559 
    5660   USE bdy_par          ! for lk_bdy 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/timing.F90

    r3610 r5620  
    211211         WRITE(numtime,*) '                             NEMO team' 
    212212         WRITE(numtime,*) '                  Ocean General Circulation Model' 
    213          WRITE(numtime,*) '                        version 3.3  (2010) ' 
     213         WRITE(numtime,*) '                        version 3.6  (2015) ' 
    214214         WRITE(numtime,*) 
    215215         WRITE(numtime,*) '                        Timing Informations ' 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/trc_oce.F90

    r4792 r5620  
    3232   !!   'key_top'                                                 bio-model           
    3333   !!---------------------------------------------------------------------- 
     34   LOGICAL, PUBLIC, PARAMETER ::   lk_top     = .TRUE.   !: TOP model 
    3435   LOGICAL, PUBLIC, PARAMETER ::   lk_qsr_bio = .TRUE.   !: bio-model light absorption flag 
    3536#else 
     
    3738   !! Default option                          No bio-model light absorption       
    3839   !!---------------------------------------------------------------------- 
     40   LOGICAL, PUBLIC, PARAMETER ::   lk_top     = .FALSE.   !: TOP model 
    3941   LOGICAL, PUBLIC, PARAMETER ::   lk_qsr_bio = .FALSE.   !: bio-model light absorption flag 
    4042#endif 
  • branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90

    • Property svn:keywords set to Id
    r3294 r5620  
    121121 
    122122   LOGICAL ::   linit = .FALSE. 
     123   LOGICAL ::   ldebug = .FALSE. 
    123124   !!---------------------------------------------------------------------- 
    124125   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    125    !! $Id:$ 
     126   !! $Id$ 
    126127   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    127128   !!---------------------------------------------------------------------- 
     
    486487       
    487488      IF( SUM( tree(ii)%ishape ) == 0 ) THEN                    ! create a new branch  
     489         IF(ldebug) PRINT *, 'create new branch ', ii,ishape, isrt, itype 
    488490         tree(ii)%itype = itype                                        ! define the type of this branch  
    489491         tree(ii)%ishape(:) = ishape(:)                                ! define the shape of this branch  
     
    515517         tree(ii)%current%next%in_use = .FALSE.                        ! this leaf is not yet used 
    516518         tree(ii)%current%next%indic = tree(ii)%current%indic + 1      ! number of this leaf 
     519         IF(ldebug) PRINT *, 'add a leaf ', ii, tree(ii)%current%indic 
    517520         tree(ii)%current%next%prev => tree(ii)%current                ! previous leaf of the new leaf is the current leaf 
    518521         tree(ii)%current%next%next => NULL()                          ! next leaf is not yet defined 
Note: See TracChangeset for help on using the changeset viewer.