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 7256 for branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3 – NEMO

Ignore:
Timestamp:
2016-11-18T08:18:45+01:00 (7 years ago)
Author:
cbricaud
Message:

phaze NEMO routines in CRS branch with nemo_v3_6_STABLE branch at rev 7213 (09-09-2016) (merge -r 5519:7213 )

Location:
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3
Files:
18 edited

Legend:

Unmodified
Added
Removed

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/ice.F90

    r5602 r7256  
    234234   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_oce, v_oce   !: surface ocean velocity used in ice dynamics 
    235235   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ahiu , ahiv    !: hor. diffusivity coeff. at U- and V-points [m2/s] 
    236    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   pahu , pahv    !: ice hor. eddy diffusivity coef. at U- and V-points 
    237236   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ust2s, hicol   !: friction velocity, ice collection thickness accreted in leads 
    238237   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   strp1, strp2   !: strength at previous time steps 
    … …  
    244243   ! 
    245244   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sist        !: Average Sea-Ice Surface Temperature [Kelvin] 
    246    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   icethi      !: total ice thickness (for all categories) (diag only) 
    247245   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   t_bo        !: Sea-Ice bottom temperature [Kelvin]      
    248246   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   frld        !: Leads fraction = 1 - ice fraction 
    … …  
    253251   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fhld        !: heat flux from the lead used for bottom melting 
    254252 
    255    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw    !: snow-ocean mass exchange over 1 time step [kg/m2] 
    256    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr    !: snow precipitation on ice over 1 time step [kg/m2] 
    257    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub    !: snow sublimation over 1 time step [kg/m2] 
    258  
    259    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice    !: ice-ocean mass exchange over 1 time step [kg/m2] 
    260    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni    !: snow ice growth component of wfx_ice [kg/m2] 
    261    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw    !: lateral ice growth component of wfx_ice [kg/m2] 
    262    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog    !: bottom ice growth component of wfx_ice [kg/m2] 
    263    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn    !: dynamical ice growth component of wfx_ice [kg/m2] 
    264    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom    !: bottom melt component of wfx_ice [kg/m2] 
    265    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum    !: surface melt component of wfx_ice [kg/m2] 
    266    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res    !: residual component of wfx_ice [kg/m2] 
    267  
    268    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total) [s-1] 
     253   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw    !: snow-ocean mass exchange   [kg.m-2.s-1] 
     254   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr    !: snow precipitation on ice  [kg.m-2.s-1] 
     255   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub    !: snow/ice sublimation       [kg.m-2.s-1] 
     256 
     257   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice    !: ice-ocean mass exchange                   [kg.m-2.s-1] 
     258   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni    !: snow ice growth component of wfx_ice      [kg.m-2.s-1] 
     259   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw    !: lateral ice growth component of wfx_ice   [kg.m-2.s-1] 
     260   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog    !: bottom ice growth component of wfx_ice    [kg.m-2.s-1] 
     261   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn    !: dynamical ice growth component of wfx_ice [kg.m-2.s-1] 
     262   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom    !: bottom melt component of wfx_ice          [kg.m-2.s-1] 
     263   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum    !: surface melt component of wfx_ice         [kg.m-2.s-1] 
     264   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res    !: residual component of wfx_ice             [kg.m-2.s-1] 
     265 
     266   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total)          [s-1] 
    269267   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_thd     !: ice concentration tendency (thermodynamics) [s-1] 
    270    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_dyn     !: ice concentration tendency (dynamics) [s-1] 
     268   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_dyn     !: ice concentration tendency (dynamics)       [s-1] 
    271269 
    272270   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bog     !: salt flux due to ice growth/melt                      [PSU/m2/s] 
    … …  
    279277   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_res     !: residual salt flux due to correction of ice thickness [PSU/m2/s] 
    280278 
    281    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth  
    282    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt  
    283    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt  
    284    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation 
    285    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice  
    286    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt  
    287    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err     !: heat flux error after heat diffusion  
    288    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux 
    289    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping  
    290    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations  
    291    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_out     !: heat flux remaining at the end of thermo transformations  
    292  
     279   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sub     !: salt flux due to ice sublimation 
     280 
     281   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth        [W.m-2] 
     282   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt          [W.m-2] 
     283   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt         [W.m-2] 
     284   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation [W.m-2] 
     285   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice   [W.m-2] 
     286   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt                          [W.m-2] 
     287   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err     !: heat flux error after heat diffusion             [W.m-2] 
     288   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 
     289   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping             [W.m-2] 
     290   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations   [W.m-2] 
     291   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_out     !: heat flux remaining at the end of thermo transformations  [W.m-2] 
     292   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 
     293    
    293294   ! heat flux associated with ice-atmosphere mass exchange 
    294    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation  
    295    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  
     295   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation  [W.m-2] 
     296   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  [W.m-2] 
    296297 
    297298   ! heat flux associated with ice-ocean mass exchange 
    298    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (limthd_dh)  
    299    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from mecanical processes (limitd_me)  
    300    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness 
    301  
    302    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice 
     299   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (limthd_dh)  [W.m-2] 
     300   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from mecanical processes (limitd_me)  [W.m-2] 
     301   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness [W.m-2] 
     302 
     303   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice    
     304   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   pahu3D , pahv3D 
     305   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rn_amax_2d  !: maximum ice concentration 2d array 
    303306 
    304307   !!-------------------------------------------------------------------------- 
    … …  
    316319   !                                                                  !  this is an extensive variable that has to be transported 
    317320   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   o_i     !: Sea-Ice Age (days) 
    318    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ov_i    !: Sea-Ice Age times volume per area (days.m) 
    319321   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   oa_i    !: Sea-Ice Age times ice area (days) 
     322   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   bv_i    !: brine volume 
    320323 
    321324   !! Variables summed over all categories, or associated to all the ice in a single grid cell 
    322325   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_ice, v_ice   !: components of the ice velocity (m/s) 
    323    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tio_u, tio_v   !: components of the ice-ocean stress (N/m2) 
    324326   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vt_i , vt_s    !: ice and snow total volume per unit area (m) 
    325327   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   at_i           !: ice total fractional area (ice concentration) 
    326328   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ato_i          !: =1-at_i ; total open water fractional area 
    327329   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   et_i , et_s    !: ice and snow total heat content 
    328    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ot_i           !: mean age over all categories 
    329    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_i           !: mean ice temperature over all categories 
    330    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bv_i           !: brine volume averaged over all categories 
    331    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   smt_i          !: mean sea ice salinity averaged over all categories [PSU] 
     330   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_i         !: mean ice temperature over all categories 
     331   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bvm_i        !: brine volume averaged over all categories 
     332   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   smt_i        !: mean sea ice salinity averaged over all categories [PSU] 
     333   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_su        !: mean surface temperature over all categories 
     334   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   htm_i        !: mean ice  thickness over all categories 
     335   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   htm_s        !: mean snow thickness over all categories 
     336   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   om_i         !: mean ice age over all categories 
    332337 
    333338   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_s        !: Snow temperatures [K] 
    … …  
    372377   INTEGER          , PUBLIC ::   nlay_i          !: number of ice  layers  
    373378   INTEGER          , PUBLIC ::   nlay_s          !: number of snow layers  
    374    CHARACTER(len=32), PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
     379   CHARACTER(len=80), PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
    375380   CHARACTER(len=256), PUBLIC ::   cn_icerst_indir !: ice restart input directory 
    376    CHARACTER(len=32), PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
     381   CHARACTER(len=80), PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
    377382   CHARACTER(len=256), PUBLIC ::   cn_icerst_outdir!: ice restart output directory 
    378383   LOGICAL          , PUBLIC ::   ln_limdyn       !: flag for ice dynamics (T) or not (F) 
    379384   LOGICAL          , PUBLIC ::   ln_icectl       !: flag for sea-ice points output (T) or not (F) 
    380    REAL(wp)         , PUBLIC ::   rn_amax         !: maximum ice concentration 
     385   REAL(wp)         , PUBLIC ::   rn_amax_n       !: maximum ice concentration Northern hemisphere 
     386   REAL(wp)         , PUBLIC ::   rn_amax_s       !: maximum ice concentration Southern hemisphere 
    381387   INTEGER          , PUBLIC ::   iiceprt         !: debug i-point 
    382388   INTEGER          , PUBLIC ::   jiceprt         !: debug j-point 
    … …  
    424430      ALLOCATE( u_oce    (jpi,jpj) , v_oce    (jpi,jpj) ,                           & 
    425431         &      ahiu     (jpi,jpj) , ahiv     (jpi,jpj) ,                           & 
    426          &      pahu     (jpi,jpj) , pahv     (jpi,jpj) ,                           & 
    427432         &      ust2s    (jpi,jpj) , hicol    (jpi,jpj) ,                           & 
    428433         &      strp1    (jpi,jpj) , strp2    (jpi,jpj) , strength  (jpi,jpj) ,     & 
    … …  
    431436 
    432437      ii = ii + 1 
    433       ALLOCATE( sist   (jpi,jpj) , icethi (jpi,jpj) , t_bo   (jpi,jpj) ,                        & 
     438      ALLOCATE( sist   (jpi,jpj) , t_bo   (jpi,jpj) ,                        & 
    434439         &      frld   (jpi,jpj) , pfrld  (jpi,jpj) , phicif (jpi,jpj) ,                        & 
    435440         &      wfx_snw(jpi,jpj) , wfx_ice(jpi,jpj) , wfx_sub(jpi,jpj) ,                        & 
    … …  
    437442         &      wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) ,     & 
    438443         &      afx_tot(jpi,jpj) , afx_thd(jpi,jpj),  afx_dyn(jpi,jpj) ,                        & 
    439          &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl), qlead  (jpi,jpj) ,                     & 
    440          &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) ,                        & 
     444         &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl), pahu3D(jpi,jpj,jpl+1), pahv3D(jpi,jpj,jpl+1),            & 
     445         &      qlead  (jpi,jpj) , rn_amax_2d(jpi,jpj),                                         & 
     446         &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj),      & 
    441447         &      sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) ,    & 
    442448         &      hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) ,     &  
    443          &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) ,                                   & 
     449         &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj) ,       & 
    444450         &      hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) ,                           & 
    445451         &      hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) ,    & 
    … …  
    451457         &      v_s  (jpi,jpj,jpl) , ht_s (jpi,jpj,jpl) , t_su (jpi,jpj,jpl) ,     & 
    452458         &      sm_i (jpi,jpj,jpl) , smv_i(jpi,jpj,jpl) , o_i  (jpi,jpj,jpl) ,     & 
    453          &      ov_i (jpi,jpj,jpl) , oa_i (jpi,jpj,jpl)                      , STAT=ierr(ii) ) 
    454       ii = ii + 1 
    455       ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) , tio_u(jpi,jpj) , tio_v(jpi,jpj) ,     & 
     459         &      oa_i (jpi,jpj,jpl) , bv_i (jpi,jpj,jpl) , STAT=ierr(ii) ) 
     460      ii = ii + 1 
     461      ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) ,      & 
    456462         &      vt_i (jpi,jpj) , vt_s (jpi,jpj) , at_i (jpi,jpj) , ato_i(jpi,jpj) ,     & 
    457          &      et_i (jpi,jpj) , et_s (jpi,jpj) , ot_i (jpi,jpj) , tm_i (jpi,jpj) ,     & 
    458          &      bv_i (jpi,jpj) , smt_i(jpi,jpj)                                   , STAT=ierr(ii) ) 
     463         &      et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i (jpi,jpj) , bvm_i(jpi,jpj) ,     & 
     464         &      smt_i(jpi,jpj) , tm_su(jpi,jpj) , htm_i(jpi,jpj) , htm_s(jpi,jpj) ,     & 
     465         &      om_i (jpi,jpj)                              , STAT=ierr(ii) ) 
    459466      ii = ii + 1 
    460467      ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) ) 
    … …  
    508515   !!====================================================================== 
    509516END MODULE ice 
     517 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90

    r5602 r7256  
    2424   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    2525   USE sbc_oce , ONLY : sfx  ! Surface boundary condition: ocean fields 
    26  
     26   USE sbc_ice , ONLY : qevap_ice 
     27    
    2728   IMPLICIT NONE 
    2829   PRIVATE 
    … …  
    184185         ! salt flux 
    185186         zfs_b  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    186             &                  sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  & 
     187            &                  sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:)                   & 
    187188            &                ) *  e12t(:,:) * tmask(:,:,1) * zconv ) 
    188189 
    … …  
    209210         ! salt flux 
    210211         zfs  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    211             &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  &  
     212            &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:)                   &  
    212213            &              ) * e12t(:,:) * tmask(:,:,1) * zconv ) - zfs_b 
    213214 
    … …  
    256257            ENDIF 
    257258            IF (     zvmin   < -epsi10 ) WRITE(numout,*) 'violation v_i<0  [m]          (',cd_routine,') = ',zvmin 
    258             IF (     zamax   > rn_amax+epsi10 .AND. cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 
     259            IF (     zamax   > MAX( rn_amax_n, rn_amax_s ) + epsi10 .AND. & 
     260               &                         cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 
    259261                                         WRITE(numout,*) 'violation a_i>amax            (',cd_routine,') = ',zamax 
    260262            ENDIF 
    … …  
    286288#if ! defined key_bdy 
    287289      ! heat flux 
    288       zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - hfx_sub ) * e12t * tmask(:,:,1) * zconv )  
     290      zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es  & 
     291      !  &              - SUM( qevap_ice * a_i_b, dim=3 )                           & !!clem: I think this line must be commented (but need check) 
     292         &              ) * e12t * tmask(:,:,1) * zconv )  
    289293      ! salt flux 
    290294      zsfx  = glob_sum( ( sfx + diag_smvi ) * e12t * tmask(:,:,1) * zconv ) * rday 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90

    r5602 r7256  
    3131 
    3232   PUBLIC   lim_diahsb        ! routine called by ice_step.F90 
    33  
    34    real(wp) ::   frc_sal, frc_vol   ! global forcing trends 
    35    real(wp) ::   bg_grme            ! global ice growth+melt trends 
    36  
     33   PUBLIC   lim_diahsb_init   ! routine called in sbcice_lim.F90 
     34 
     35   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   vol_loc_ini, sal_loc_ini, tem_loc_ini ! initial volume, salt and heat contents 
     36   REAL(wp)                              ::   frc_sal, frc_voltop, frc_volbot, frc_temtop, frc_tembot  ! global forcing trends 
     37    
    3738   !! * Substitutions 
    3839#  include "vectopt_loop_substitute.h90" 
    … …  
    4647CONTAINS 
    4748 
    48    SUBROUTINE lim_diahsb 
     49   SUBROUTINE lim_diahsb( kt ) 
    4950      !!--------------------------------------------------------------------------- 
    5051      !!                  ***  ROUTINE lim_diahsb  *** 
    … …  
    5354      !!  
    5455      !!--------------------------------------------------------------------------- 
     56      INTEGER, INTENT(in) :: kt    ! number of iteration 
    5557      !! 
    56       real(wp)   ::   zbg_ivo, zbg_svo, zbg_are, zbg_sal ,zbg_tem ,zbg_ihc ,zbg_shc 
    57       real(wp)   ::   zbg_sfx, zbg_sfx_bri, zbg_sfx_bog, zbg_sfx_bom, zbg_sfx_sum, zbg_sfx_sni,   & 
    58       &               zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn  
    59       real(wp)   ::   zbg_vfx, zbg_vfx_bog, zbg_vfx_opw, zbg_vfx_sni, zbg_vfx_dyn 
    60       real(wp)   ::   zbg_vfx_bom, zbg_vfx_sum, zbg_vfx_res, zbg_vfx_spr, zbg_vfx_snw, zbg_vfx_sub   
    61       real(wp)   ::   zbg_hfx_dhc, zbg_hfx_spr 
    62       real(wp)   ::   zbg_hfx_res, zbg_hfx_sub, zbg_hfx_dyn, zbg_hfx_thd, zbg_hfx_snw, zbg_hfx_out, zbg_hfx_in    
    63       real(wp)   ::   zbg_hfx_sum, zbg_hfx_bom, zbg_hfx_bog, zbg_hfx_dif, zbg_hfx_opw 
    64       real(wp)   ::   z_frc_vol, z_frc_sal, z_bg_grme  
    65       real(wp)   ::   z1_area                     !    -     - 
    66       REAL(wp)   ::   ztmp 
     58      real(wp)   ::   zbg_ivol, zbg_svol, zbg_area, zbg_isal, zbg_item ,zbg_stem 
     59      REAL(wp)   ::   z_frc_voltop, z_frc_volbot, z_frc_sal, z_frc_temtop, z_frc_tembot   
     60      REAL(wp)   ::   zdiff_vol, zdiff_sal, zdiff_tem   
    6761      !!--------------------------------------------------------------------------- 
    6862      IF( nn_timing == 1 )   CALL timing_start('lim_diahsb') 
    6963 
    70       IF( numit == nstart ) CALL lim_diahsb_init  
    71  
    72       ! 1/area 
    73       z1_area = 1._wp / MAX( glob_sum( e12t(:,:) * tmask(:,:,1) ), epsi06 ) 
    74  
    75       rswitch = MAX( 0._wp , SIGN( 1._wp , glob_sum( e12t(:,:) * tmask(:,:,1) ) - epsi06 ) ) 
    76       ! ----------------------- ! 
    77       ! 1 -  Content variations ! 
    78       ! ----------------------- ! 
    79       zbg_ivo = glob_sum( vt_i(:,:) * e12t(:,:) * tmask(:,:,1) ) ! volume ice  
    80       zbg_svo = glob_sum( vt_s(:,:) * e12t(:,:) * tmask(:,:,1) ) ! volume snow 
    81       zbg_are = glob_sum( at_i(:,:) * e12t(:,:) * tmask(:,:,1) ) ! area 
    82       zbg_sal = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * e12t(:,:) * tmask(:,:,1) )       ! mean salt content 
    83       zbg_tem = glob_sum( ( tm_i(:,:) - rt0 ) * vt_i(:,:) * e12t(:,:) * tmask(:,:,1) )  ! mean temp content 
    84  
    85       !zbg_ihc = glob_sum( et_i(:,:) * e12t(:,:) * tmask(:,:,1) ) / MAX( zbg_ivo,epsi06 ) ! ice heat content 
    86       !zbg_shc = glob_sum( et_s(:,:) * e12t(:,:) * tmask(:,:,1) ) / MAX( zbg_svo,epsi06 ) ! snow heat content 
    87  
    88       ! Volume 
    89       ztmp = rswitch * z1_area * r1_rau0 * rday 
    90       zbg_vfx     = ztmp * glob_sum(     emp(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    91       zbg_vfx_bog = ztmp * glob_sum( wfx_bog(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    92       zbg_vfx_opw = ztmp * glob_sum( wfx_opw(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    93       zbg_vfx_sni = ztmp * glob_sum( wfx_sni(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    94       zbg_vfx_dyn = ztmp * glob_sum( wfx_dyn(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    95       zbg_vfx_bom = ztmp * glob_sum( wfx_bom(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    96       zbg_vfx_sum = ztmp * glob_sum( wfx_sum(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    97       zbg_vfx_res = ztmp * glob_sum( wfx_res(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    98       zbg_vfx_spr = ztmp * glob_sum( wfx_spr(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    99       zbg_vfx_snw = ztmp * glob_sum( wfx_snw(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    100       zbg_vfx_sub = ztmp * glob_sum( wfx_sub(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    101  
    102       ! Salt 
    103       zbg_sfx     = ztmp * glob_sum(     sfx(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    104       zbg_sfx_bri = ztmp * glob_sum( sfx_bri(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    105       zbg_sfx_res = ztmp * glob_sum( sfx_res(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    106       zbg_sfx_dyn = ztmp * glob_sum( sfx_dyn(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    107  
    108       zbg_sfx_bog = ztmp * glob_sum( sfx_bog(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    109       zbg_sfx_opw = ztmp * glob_sum( sfx_opw(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    110       zbg_sfx_sni = ztmp * glob_sum( sfx_sni(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    111       zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    112       zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    113  
    114       ! Heat budget 
    115       zbg_ihc      = glob_sum( et_i(:,:) * e12t(:,:) * 1.e-20 ) ! ice heat content  [1.e20 J] 
    116       zbg_shc      = glob_sum( et_s(:,:) * e12t(:,:) * 1.e-20 ) ! snow heat content [1.e20 J] 
    117       zbg_hfx_dhc  = glob_sum( diag_heat(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    118       zbg_hfx_spr  = glob_sum( hfx_spr(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    119  
    120       zbg_hfx_thd  = glob_sum( hfx_thd(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    121       zbg_hfx_dyn  = glob_sum( hfx_dyn(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    122       zbg_hfx_res  = glob_sum( hfx_res(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    123       zbg_hfx_sub  = glob_sum( hfx_sub(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    124       zbg_hfx_snw  = glob_sum( hfx_snw(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    125       zbg_hfx_sum  = glob_sum( hfx_sum(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    126       zbg_hfx_bom  = glob_sum( hfx_bom(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    127       zbg_hfx_bog  = glob_sum( hfx_bog(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    128       zbg_hfx_dif  = glob_sum( hfx_dif(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    129       zbg_hfx_opw  = glob_sum( hfx_opw(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    130       zbg_hfx_out  = glob_sum( hfx_out(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    131       zbg_hfx_in   = glob_sum(  hfx_in(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    132      
    133       ! --------------------------------------------- ! 
    134       ! 2 - Trends due to forcing and ice growth/melt ! 
    135       ! --------------------------------------------- ! 
    136       z_frc_vol = r1_rau0 * glob_sum( - emp(:,:) * e12t(:,:) * tmask(:,:,1) ) ! volume fluxes 
    137       z_frc_sal = r1_rau0 * glob_sum(   sfx(:,:) * e12t(:,:) * tmask(:,:,1) ) ! salt fluxes 
    138       z_bg_grme = glob_sum( - ( wfx_bog(:,:) + wfx_opw(:,:) + wfx_sni(:,:) + wfx_dyn(:,:) + & 
    139                           &     wfx_bom(:,:) + wfx_sum(:,:) + wfx_res(:,:) + wfx_snw(:,:) + & 
    140                           &     wfx_sub(:,:) ) * e12t(:,:) * tmask(:,:,1) ) ! volume fluxes 
    141       ! 
    142       frc_vol  = frc_vol  + z_frc_vol  * rdt_ice 
    143       frc_sal  = frc_sal  + z_frc_sal  * rdt_ice 
    144       bg_grme  = bg_grme  + z_bg_grme  * rdt_ice 
     64      ! ----------------------- ! 
     65      ! 1 -  Contents ! 
     66      ! ----------------------- ! 
     67      zbg_ivol = glob_sum( vt_i(:,:) * e12t(:,:) * tmask(:,:,1) * 1.e-9 )                  ! ice volume (km3) 
     68      zbg_svol = glob_sum( vt_s(:,:) * e12t(:,:) * tmask(:,:,1) * 1.e-9 )                  ! snow volume (km3) 
     69      zbg_area = glob_sum( at_i(:,:) * e12t(:,:) * tmask(:,:,1) * 1.e-6 )                  ! area (km2) 
     70      zbg_isal = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * e12t(:,:) * tmask(:,:,1) * 1.e-9 ) ! salt content (pss*km3) 
     71      zbg_item = glob_sum( et_i * e12t(:,:) * tmask(:,:,1) * 1.e-20 )                      ! heat content (1.e20 J) 
     72      zbg_stem = glob_sum( et_s * e12t(:,:) * tmask(:,:,1) * 1.e-20 )                      ! heat content (1.e20 J) 
    14573       
    146       ! difference 
    147       !frc_vol = zbg_ivo - frc_vol 
    148       !frc_sal = zbg_sal - frc_sal 
    149        
    150       ! ----------------------- ! 
    151       ! 3 - Diagnostics writing ! 
    152       ! ----------------------- ! 
    153       rswitch = MAX( 0._wp , SIGN( 1._wp , zbg_ivo - epsi06 ) ) 
    154       ! 
    155       IF( iom_use('ibgvoltot') )   & 
    156       CALL iom_put( 'ibgvoltot' , zbg_ivo * rhoic * r1_rau0 * 1.e-9        )   ! ice volume (km3 equivalent liquid)          
    157       IF( iom_use('sbgvoltot') )   & 
    158       CALL iom_put( 'sbgvoltot' , zbg_svo * rhosn * r1_rau0 * 1.e-9        )   ! snw volume (km3 equivalent liquid)        
    159       IF( iom_use('ibgarea') )   & 
    160       CALL iom_put( 'ibgarea'   , zbg_are * 1.e-6                          )   ! ice area   (km2) 
    161       IF( iom_use('ibgsaline') )   & 
    162       CALL iom_put( 'ibgsaline' , rswitch * zbg_sal / MAX( zbg_ivo, epsi06 ) )   ! ice saline (psu) 
    163       IF( iom_use('ibgtemper') )   & 
    164       CALL iom_put( 'ibgtemper' , rswitch * zbg_tem / MAX( zbg_ivo, epsi06 ) )   ! ice temper (C) 
    165       CALL iom_put( 'ibgheatco' , zbg_ihc                                  )   ! ice heat content (1.e20 J)         
    166       CALL iom_put( 'sbgheatco' , zbg_shc                                  )   ! snw heat content (1.e20 J) 
    167       IF( iom_use('ibgsaltco') )   & 
    168       CALL iom_put( 'ibgsaltco' , zbg_sal * rhoic * r1_rau0 * 1.e-9        )   ! ice salt content (psu*km3 equivalent liquid)         
    169  
    170       CALL iom_put( 'ibgvfx'    , zbg_vfx                                  )   ! volume flux emp (m/day liquid) 
    171       CALL iom_put( 'ibgvfxbog' , zbg_vfx_bog                              )   ! volume flux bottom growth     -(m/day equivalent liquid) 
    172       CALL iom_put( 'ibgvfxopw' , zbg_vfx_opw                              )   ! volume flux open water growth - 
    173       CALL iom_put( 'ibgvfxsni' , zbg_vfx_sni                              )   ! volume flux snow ice growth   - 
    174       CALL iom_put( 'ibgvfxdyn' , zbg_vfx_dyn                              )   ! volume flux dynamic growth    - 
    175       CALL iom_put( 'ibgvfxbom' , zbg_vfx_bom                              )   ! volume flux bottom melt       - 
    176       CALL iom_put( 'ibgvfxsum' , zbg_vfx_sum                              )   ! volume flux surface melt      - 
    177       CALL iom_put( 'ibgvfxres' , zbg_vfx_res                              )   ! volume flux resultant         - 
    178       CALL iom_put( 'ibgvfxspr' , zbg_vfx_spr                              )   ! volume flux from snow precip         - 
    179       CALL iom_put( 'ibgvfxsnw' , zbg_vfx_snw                              )   ! volume flux from snow melt         - 
    180       CALL iom_put( 'ibgvfxsub' , zbg_vfx_sub                              )   ! volume flux from sublimation         - 
    181            
    182       CALL iom_put( 'ibgsfx'    , zbg_sfx                                  )   ! salt flux         -(psu*m/day equivalent liquid)        
    183       CALL iom_put( 'ibgsfxbri' , zbg_sfx_bri                              )   ! salt flux brines  -       
    184       CALL iom_put( 'ibgsfxdyn' , zbg_sfx_dyn                              )   ! salt flux dynamic -     
    185       CALL iom_put( 'ibgsfxres' , zbg_sfx_res                              )   ! salt flux result  -     
    186       CALL iom_put( 'ibgsfxbog' , zbg_sfx_bog                              )   ! salt flux bottom growth    
    187       CALL iom_put( 'ibgsfxopw' , zbg_sfx_opw                              )   ! salt flux open water growth - 
    188       CALL iom_put( 'ibgsfxsni' , zbg_sfx_sni                              )   ! salt flux snow ice growth   - 
    189       CALL iom_put( 'ibgsfxbom' , zbg_sfx_bom                              )   ! salt flux bottom melt       - 
    190       CALL iom_put( 'ibgsfxsum' , zbg_sfx_sum                              )   ! salt flux surface melt      - 
    191  
    192       CALL iom_put( 'ibghfxdhc' , zbg_hfx_dhc                              )   ! Heat content variation in snow and ice [W] 
    193       CALL iom_put( 'ibghfxspr' , zbg_hfx_spr                              )   ! Heat content of snow precip [W] 
    194  
    195       CALL iom_put( 'ibghfxres' , zbg_hfx_res                              )   !  
    196       CALL iom_put( 'ibghfxsub' , zbg_hfx_sub                              )   !  
    197       CALL iom_put( 'ibghfxdyn' , zbg_hfx_dyn                              )   !  
    198       CALL iom_put( 'ibghfxthd' , zbg_hfx_thd                              )   !  
    199       CALL iom_put( 'ibghfxsnw' , zbg_hfx_snw                              )   !  
    200       CALL iom_put( 'ibghfxsum' , zbg_hfx_sum                              )   !  
    201       CALL iom_put( 'ibghfxbom' , zbg_hfx_bom                              )   !  
    202       CALL iom_put( 'ibghfxbog' , zbg_hfx_bog                              )   !  
    203       CALL iom_put( 'ibghfxdif' , zbg_hfx_dif                              )   !  
    204       CALL iom_put( 'ibghfxopw' , zbg_hfx_opw                              )   !  
    205       CALL iom_put( 'ibghfxout' , zbg_hfx_out                              )   !  
    206       CALL iom_put( 'ibghfxin'  , zbg_hfx_in                               )   !  
    207  
    208       CALL iom_put( 'ibgfrcvol' , frc_vol * 1.e-9                          )   ! vol - forcing     (km3 equivalent liquid)  
    209       CALL iom_put( 'ibgfrcsfx' , frc_sal * 1.e-9                          )   ! sal - forcing     (psu*km3 equivalent liquid)    
    210       IF( iom_use('ibgvolgrm') )   & 
    211       CALL iom_put( 'ibgvolgrm' , bg_grme * r1_rau0 * 1.e-9                )   ! vol growth + melt (km3 equivalent liquid)          
    212  
     74      ! ---------------------------! 
     75      ! 2 - Trends due to forcing  ! 
     76      ! ---------------------------! 
     77      z_frc_volbot = r1_rau0 * glob_sum( - ( wfx_ice(:,:) + wfx_snw(:,:) + wfx_err_sub(:,:) ) * e12t(:,:) * tmask(:,:,1) * 1.e-9 )  ! freshwater flux ice/snow-ocean  
     78      z_frc_voltop = r1_rau0 * glob_sum( - ( wfx_sub(:,:) + wfx_spr(:,:) ) * e12t(:,:) * tmask(:,:,1) * 1.e-9 )                     ! freshwater flux ice/snow-atm 
     79      z_frc_sal    = r1_rau0 * glob_sum( - sfx(:,:) * e12t(:,:) * tmask(:,:,1) * 1.e-9 )                                            ! salt fluxes ice/snow-ocean 
     80      z_frc_tembot =           glob_sum( hfx_out(:,:) * e12t(:,:) * tmask(:,:,1) * 1.e-20 )                                         ! heat on top of ocean (and below ice) 
     81      z_frc_temtop =           glob_sum( hfx_in (:,:) * e12t(:,:) * tmask(:,:,1) * 1.e-20 )                                         ! heat on top of ice-coean 
     82      ! 
     83      frc_voltop  = frc_voltop  + z_frc_voltop  * rdt_ice ! km3 
     84      frc_volbot  = frc_volbot  + z_frc_volbot  * rdt_ice ! km3 
     85      frc_sal     = frc_sal     + z_frc_sal     * rdt_ice ! km3*pss 
     86      frc_temtop  = frc_temtop  + z_frc_temtop  * rdt_ice ! 1.e20 J 
     87      frc_tembot  = frc_tembot  + z_frc_tembot  * rdt_ice ! 1.e20 J 
     88             
     89      ! ----------------------- ! 
     90      ! 3 -  Content variations ! 
     91      ! ----------------------- ! 
     92      zdiff_vol = r1_rau0 * glob_sum( ( rhoic * vt_i(:,:) + rhosn * vt_s(:,:) - vol_loc_ini(:,:)  &  ! freshwater trend (km3)  
     93         &                            ) * e12t(:,:) * tmask(:,:,1) * 1.e-9 )  
     94      zdiff_sal = r1_rau0 * glob_sum( ( rhoic * SUM( smv_i(:,:,:), dim=3 ) - sal_loc_ini(:,:)     &  ! salt content trend (km3*pss) 
     95         &                            ) * e12t(:,:) * tmask(:,:,1) * 1.e-9 ) 
     96      zdiff_tem =           glob_sum( ( et_i(:,:) + et_s(:,:) - tem_loc_ini(:,:)                  &  ! heat content trend (1.e20 J) 
     97      !  &                            + SUM( qevap_ice * a_i_b, dim=3 ) &     !! clem: I think this line should be commented (but needs a check) 
     98         &                            ) * e12t(:,:) * tmask(:,:,1) * 1.e-20 ) 
     99 
     100      ! ----------------------- ! 
     101      ! 4 -  Drifts             ! 
     102      ! ----------------------- ! 
     103      zdiff_vol = zdiff_vol - ( frc_voltop + frc_volbot ) 
     104      zdiff_sal = zdiff_sal - frc_sal 
     105      zdiff_tem = zdiff_tem - ( frc_tembot - frc_temtop ) 
     106 
     107      ! ----------------------- ! 
     108      ! 5 - Diagnostics writing ! 
     109      ! ----------------------- ! 
     110      ! 
     111      IF( iom_use('ibgvolume') )  CALL iom_put( 'ibgvolume' , zdiff_vol        )   ! ice/snow volume  drift            (km3 equivalent ocean water)          
     112      IF( iom_use('ibgsaltco') )  CALL iom_put( 'ibgsaltco' , zdiff_sal        )   ! ice salt content drift            (psu*km3 equivalent ocean water) 
     113      IF( iom_use('ibgheatco') )  CALL iom_put( 'ibgheatco' , zdiff_tem        )   ! ice/snow heat content drift       (1.e20 J) 
     114      IF( iom_use('ibgheatfx') )  CALL iom_put( 'ibgheatfx' , zdiff_tem /      &   ! ice/snow heat flux drift          (W/m2) 
     115         &                                                    glob_sum( e12t(:,:) * tmask(:,:,1) * 1.e-20 * kt*rdt ) ) 
     116 
     117      IF( iom_use('ibgfrcvoltop') )  CALL iom_put( 'ibgfrcvoltop' , frc_voltop )   ! vol  forcing ice/snw-atm          (km3 equivalent ocean water)  
     118      IF( iom_use('ibgfrcvolbot') )  CALL iom_put( 'ibgfrcvolbot' , frc_volbot )   ! vol  forcing ice/snw-ocean        (km3 equivalent ocean water)  
     119      IF( iom_use('ibgfrcsal') )     CALL iom_put( 'ibgfrcsal'    , frc_sal    )   ! sal - forcing                     (psu*km3 equivalent ocean water)    
     120      IF( iom_use('ibgfrctemtop') )  CALL iom_put( 'ibgfrctemtop' , frc_temtop )   ! heat on top of ice/snw/ocean      (1.e20 J)    
     121      IF( iom_use('ibgfrctembot') )  CALL iom_put( 'ibgfrctembot' , frc_tembot )   ! heat on top of ocean(below ice)   (1.e20 J)    
     122      IF( iom_use('ibgfrchfxtop') )  CALL iom_put( 'ibgfrchfxtop' , frc_temtop / & ! heat on top of ice/snw/ocean      (W/m2)  
     123         &                                                    glob_sum( e12t(:,:) * tmask(:,:,1) * 1.e-20 * kt*rdt ) ) 
     124      IF( iom_use('ibgfrchfxbot') )  CALL iom_put( 'ibgfrchfxbot' , frc_tembot / & ! heat on top of ocean(below ice)   (W/m2)  
     125         &                                                    glob_sum( e12t(:,:) * tmask(:,:,1) * 1.e-20 * kt*rdt ) ) 
     126 
     127      IF( iom_use('ibgvol_tot' ) )  CALL iom_put( 'ibgvol_tot'  , zbg_ivol     )   ! ice volume                        (km3) 
     128      IF( iom_use('sbgvol_tot' ) )  CALL iom_put( 'sbgvol_tot'  , zbg_svol     )   ! snow volume                       (km3) 
     129      IF( iom_use('ibgarea_tot') )  CALL iom_put( 'ibgarea_tot' , zbg_area     )   ! ice area                          (km2) 
     130      IF( iom_use('ibgsalt_tot') )  CALL iom_put( 'ibgsalt_tot' , zbg_isal     )   ! ice salinity content              (pss*km3) 
     131      IF( iom_use('ibgheat_tot') )  CALL iom_put( 'ibgheat_tot' , zbg_item     )   ! ice heat content                  (1.e20 J) 
     132      IF( iom_use('sbgheat_tot') )  CALL iom_put( 'sbgheat_tot' , zbg_stem     )   ! snow heat content                 (1.e20 J) 
    213133      ! 
    214134      IF( lrst_ice )   CALL lim_diahsb_rst( numit, 'WRITE' ) 
    215135      ! 
    216136      IF( nn_timing == 1 )   CALL timing_stop('lim_diahsb') 
    217 ! 
     137      ! 
    218138   END SUBROUTINE lim_diahsb 
    219139 
    … …  
    231151      !!             - Compute coefficients for conversion 
    232152      !!--------------------------------------------------------------------------- 
    233       INTEGER            ::   jk       ! dummy loop indice 
    234153      INTEGER            ::   ierror   ! local integer 
    235154      !! 
    … …  
    245164         WRITE(numout,*) '~~~~~~~~~~~~' 
    246165      ENDIF 
    247       ! 
     166      !       
     167      ALLOCATE( vol_loc_ini(jpi,jpj), sal_loc_ini(jpi,jpj), tem_loc_ini(jpi,jpj), STAT=ierror ) 
     168      IF( ierror > 0 )  THEN 
     169         CALL ctl_stop( 'lim_diahsb: unable to allocate vol_loc_ini' ) 
     170         RETURN 
     171      ENDIF 
     172 
    248173      CALL lim_diahsb_rst( nstart, 'READ' )  !* read or initialize all required files 
    249174      ! 
    … …  
    261186     CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag 
    262187     ! 
    263      INTEGER ::   id1, id2, id3   ! local integers 
    264188     !!---------------------------------------------------------------------- 
    265189     ! 
    266190     IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise  
    267191        IF( ln_rstart ) THEN                   !* Read the restart file 
    268            !id1 = iom_varid( numrir, 'frc_vol'  , ldstop = .TRUE. ) 
    269192           ! 
    270193           IF(lwp) WRITE(numout,*) '~~~~~~~' 
    271            IF(lwp) WRITE(numout,*) ' lim_diahsb_rst at it= ', kt,' date= ', ndastp 
    272            IF(lwp) WRITE(numout,*) '~~~~~~~' 
    273            CALL iom_get( numrir, 'frc_vol', frc_vol ) 
    274            CALL iom_get( numrir, 'frc_sal', frc_sal ) 
    275            CALL iom_get( numrir, 'bg_grme', bg_grme ) 
     194           IF(lwp) WRITE(numout,*) ' lim_diahsb_rst read at it= ', kt,' date= ', ndastp 
     195           IF(lwp) WRITE(numout,*) '~~~~~~~' 
     196           CALL iom_get( numrir, 'frc_voltop' , frc_voltop  ) 
     197           CALL iom_get( numrir, 'frc_volbot' , frc_volbot  ) 
     198           CALL iom_get( numrir, 'frc_temtop' , frc_temtop  ) 
     199           CALL iom_get( numrir, 'frc_tembot' , frc_tembot  ) 
     200           CALL iom_get( numrir, 'frc_sal'    , frc_sal     ) 
     201           CALL iom_get( numrir, jpdom_autoglo, 'vol_loc_ini', vol_loc_ini ) 
     202           CALL iom_get( numrir, jpdom_autoglo, 'tem_loc_ini', tem_loc_ini ) 
     203           CALL iom_get( numrir, jpdom_autoglo, 'sal_loc_ini', sal_loc_ini ) 
    276204        ELSE 
    277205           IF(lwp) WRITE(numout,*) '~~~~~~~' 
    278206           IF(lwp) WRITE(numout,*) ' lim_diahsb at initial state ' 
    279207           IF(lwp) WRITE(numout,*) '~~~~~~~' 
    280            frc_vol  = 0._wp                                           
    281            frc_sal  = 0._wp                                                  
    282            bg_grme  = 0._wp                                        
     208           ! set trends to 0 
     209           frc_voltop  = 0._wp                                           
     210           frc_volbot  = 0._wp                                           
     211           frc_temtop  = 0._wp                                                  
     212           frc_tembot  = 0._wp                                                  
     213           frc_sal     = 0._wp                                                  
     214           ! record initial ice volume, salt and temp 
     215           vol_loc_ini(:,:) = rhoic * vt_i(:,:) + rhosn * vt_s(:,:)  ! ice/snow volume (kg/m2) 
     216           tem_loc_ini(:,:) = et_i(:,:) + et_s(:,:)                  ! ice/snow heat content (J) 
     217           sal_loc_ini(:,:) = rhoic * SUM( smv_i(:,:,:), dim=3 )     ! ice salt content (pss*kg/m2) 
     218            
    283219       ENDIF 
    284220 
    … …  
    286222        !                                   ! ------------------- 
    287223        IF(lwp) WRITE(numout,*) '~~~~~~~' 
    288         IF(lwp) WRITE(numout,*) ' lim_diahsb_rst at it= ', kt,' date= ', ndastp 
     224        IF(lwp) WRITE(numout,*) ' lim_diahsb_rst write at it= ', kt,' date= ', ndastp 
    289225        IF(lwp) WRITE(numout,*) '~~~~~~~' 
    290         CALL iom_rstput( kt, nitrst, numriw, 'frc_vol'   , frc_vol     ) 
    291         CALL iom_rstput( kt, nitrst, numriw, 'frc_sal'   , frc_sal     ) 
    292         CALL iom_rstput( kt, nitrst, numriw, 'bg_grme'   , bg_grme     ) 
     226        CALL iom_rstput( kt, nitrst, numriw, 'frc_voltop' , frc_voltop  ) 
     227        CALL iom_rstput( kt, nitrst, numriw, 'frc_volbot' , frc_volbot  ) 
     228        CALL iom_rstput( kt, nitrst, numriw, 'frc_temtop' , frc_temtop  ) 
     229        CALL iom_rstput( kt, nitrst, numriw, 'frc_tembot' , frc_tembot  ) 
     230        CALL iom_rstput( kt, nitrst, numriw, 'frc_sal'    , frc_sal     ) 
     231        CALL iom_rstput( kt, nitrst, numriw, 'vol_loc_ini', vol_loc_ini ) 
     232        CALL iom_rstput( kt, nitrst, numriw, 'tem_loc_ini', tem_loc_ini ) 
     233        CALL iom_rstput( kt, nitrst, numriw, 'sal_loc_ini', sal_loc_ini ) 
    293234        ! 
    294235     ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90

    r5602 r7256  
    77   !!             -   !  2001-05 (G. Madec, R. Hordoir) opa norm 
    88   !!            1.0  !  2002-08 (C. Ethe)  F90, free form 
     9   !!            3.0  !  2015-08 (O. Tintó and M. Castrillo)  added lim_hdf (multiple) 
    910   !!---------------------------------------------------------------------- 
    1011#if defined key_lim3 
    … …  
    2728   PRIVATE 
    2829 
    29    PUBLIC   lim_hdf         ! called by lim_trp 
     30   PUBLIC   lim_hdf ! called by lim_trp 
    3031   PUBLIC   lim_hdf_init    ! called by sbc_lim_init 
    3132 
    … …  
    4344CONTAINS 
    4445 
    45    SUBROUTINE lim_hdf( ptab ) 
     46   SUBROUTINE lim_hdf( ptab , ihdf_vars , jpl , nlay_i ) 
    4647      !!------------------------------------------------------------------- 
    4748      !!                  ***  ROUTINE lim_hdf  *** 
    … …  
    5455      !! ** Action  :    update ptab with the diffusive contribution 
    5556      !!------------------------------------------------------------------- 
    56       REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   ptab    ! Field on which the diffusion is applied 
    57       ! 
    58       INTEGER                           ::  ji, jj                    ! dummy loop indices 
     57      INTEGER                           :: jpl, nlay_i, isize, ihdf_vars 
     58      REAL(wp),  DIMENSION(:,:,:), INTENT( inout ),TARGET ::   ptab    ! Field on which the diffusion is applied 
     59      ! 
     60      INTEGER                           ::  ji, jj, jk, jl , jm               ! dummy loop indices 
    5961      INTEGER                           ::  iter, ierr           ! local integers 
    60       REAL(wp)                          ::  zrlxint, zconv     ! local scalars 
    61       REAL(wp), POINTER, DIMENSION(:,:) ::  zrlx, zflu, zflv, zdiv0, zdiv, ztab0 
     62      REAL(wp)                          ::  zrlxint     ! local scalars 
     63      REAL(wp), POINTER , DIMENSION ( : )        :: zconv     ! local scalars 
     64      REAL(wp), POINTER , DIMENSION(:,:,:) ::  zrlx,zdiv0, ztab0 
     65      REAL(wp), POINTER , DIMENSION(:,:) ::  zflu, zflv, zdiv 
    6266      CHARACTER(lc)                     ::  charout                   ! local character 
    6367      REAL(wp), PARAMETER               ::  zrelax = 0.5_wp           ! relaxation constant for iterative procedure 
    … …  
    6569      INTEGER , PARAMETER               ::  its    = 100              ! Maximum number of iteration 
    6670      !!------------------------------------------------------------------- 
     71      TYPE(arrayptr)   , ALLOCATABLE, DIMENSION(:) ::   pt2d_array, zrlx_array 
     72      CHARACTER(len=1) , ALLOCATABLE, DIMENSION(:) ::   type_array ! define the nature of ptab array grid-points 
     73      !                                                            ! = T , U , V , F , W and I points 
     74      REAL(wp)        , ALLOCATABLE, DIMENSION(:)  ::   psgn_array    ! =-1 the sign change across the north fold boundary 
     75 
     76     !!---------------------------------------------------------------------  
     77 
     78      !                       !==  Initialisation  ==! 
     79      ! +1 open water diffusion 
     80      isize = jpl*(ihdf_vars+nlay_i)+1 
     81      ALLOCATE( zconv (isize) ) 
     82      ALLOCATE( pt2d_array(isize) , zrlx_array(isize) ) 
     83      ALLOCATE( type_array(isize) ) 
     84      ALLOCATE( psgn_array(isize) ) 
    6785       
    68       CALL wrk_alloc( jpi, jpj, zrlx, zflu, zflv, zdiv0, zdiv, ztab0 ) 
    69  
    70       !                       !==  Initialisation  ==! 
     86      CALL wrk_alloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 
     87      CALL wrk_alloc( jpi, jpj, zflu, zflv, zdiv ) 
     88 
     89      DO jk= 1 , isize 
     90         pt2d_array(jk)%pt2d=>ptab(:,:,jk) 
     91         zrlx_array(jk)%pt2d=>zrlx(:,:,jk) 
     92         type_array(jk)='T' 
     93         psgn_array(jk)=1. 
     94      END DO 
     95 
    7196      ! 
    7297      IF( linit ) THEN              ! Metric coefficient (compute at the first call and saved in efact) 
    … …  
    7499         IF( lk_mpp    )   CALL mpp_sum( ierr ) 
    75100         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'lim_hdf : unable to allocate arrays' ) 
    76          DO jj = 2, jpjm1   
     101         DO jj = 2, jpjm1 
    77102            DO ji = fs_2 , fs_jpim1   ! vector opt. 
    78103               efact(ji,jj) = ( e2u(ji,jj) + e2u(ji-1,jj) + e1v(ji,jj) + e1v(ji,jj-1) ) * r1_e12t(ji,jj) 
    … …  
    83108      !                             ! Time integration parameters 
    84109      ! 
    85       ztab0(:, : ) = ptab(:,:)      ! Arrays initialization 
    86       zdiv0(:, 1 ) = 0._wp 
    87       zdiv0(:,jpj) = 0._wp 
    88       zflu (jpi,:) = 0._wp    
    89       zflv (jpi,:) = 0._wp 
    90       zdiv0(1,  :) = 0._wp 
    91       zdiv0(jpi,:) = 0._wp 
     110      zflu (jpi,: ) = 0._wp 
     111      zflv (jpi,: ) = 0._wp 
     112 
     113      DO jk=1 , isize 
     114         ztab0(:, : , jk ) = ptab(:,:,jk)      ! Arrays initialization 
     115         zdiv0(:, 1 , jk ) = 0._wp 
     116         zdiv0(:,jpj, jk ) = 0._wp 
     117         zdiv0(1,  :, jk ) = 0._wp 
     118         zdiv0(jpi,:, jk ) = 0._wp 
     119      END DO 
    92120 
    93121      zconv = 1._wp           !==  horizontal diffusion using a Crant-Nicholson scheme  ==! 
    94122      iter  = 0 
    95123      ! 
    96       DO WHILE( zconv > ( 2._wp * 1.e-04 ) .AND. iter <= its )   ! Sub-time step loop 
     124      DO WHILE( MAXVAL(zconv(:)) > ( 2._wp * 1.e-04 ) .AND. iter <= its )   ! Sub-time step loop 
    97125         ! 
    98126         iter = iter + 1                                 ! incrementation of the sub-time step number 
    99127         ! 
     128         DO jk = 1 , isize 
     129            jl = (jk-1) /( ihdf_vars+nlay_i)+1 
     130            IF (zconv(jk) > ( 2._wp * 1.e-04 )) THEN 
     131               DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
     132                  DO ji = 1 , fs_jpim1   ! vector opt. 
     133                     zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 
     134                     zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 
     135                  END DO 
     136               END DO 
     137               ! 
     138               DO jj= 2, jpjm1                                 ! diffusive trend : divergence of the fluxes 
     139                  DO ji = fs_2 , fs_jpim1   ! vector opt.  
     140                     zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 
     141                  END DO 
     142               END DO 
     143               ! 
     144               IF( iter == 1 )   zdiv0(:,:,jk) = zdiv(:,:)        ! save the 1st evaluation of the diffusive trend in zdiv0 
     145               ! 
     146               DO jj = 2, jpjm1                                ! iterative evaluation 
     147                  DO ji = fs_2 , fs_jpim1   ! vector opt. 
     148                     zrlxint = (   ztab0(ji,jj,jk)    & 
     149                        &       +  rdt_ice * (           zalfa   * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj,jk) )   & 
     150                        &                      + ( 1.0 - zalfa ) *   zdiv0(ji,jj,jk) )                               & 
     151                        &      ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 
     152                     zrlx(ji,jj,jk) = ptab(ji,jj,jk) + zrelax * ( zrlxint - ptab(ji,jj,jk) ) 
     153                  END DO 
     154               END DO 
     155            END IF 
     156 
     157         END DO 
     158 
     159         CALL lbc_lnk_multi( zrlx_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     160         ! 
     161          
     162         IF ( MOD( iter-1 , nn_convfrq ) == 0 )  THEN   !Convergence test every nn_convfrq iterations (perf. optimization )  
     163            DO jk=1,isize 
     164               zconv(jk) = 0._wp                                   ! convergence test 
     165               DO jj = 2, jpjm1 
     166                  DO ji = fs_2, fs_jpim1 
     167                     zconv(jk) = MAX( zconv(jk), ABS( zrlx(ji,jj,jk) - ptab(ji,jj,jk) )  ) 
     168                  END DO 
     169               END DO 
     170            END DO 
     171            IF( lk_mpp ) CALL mpp_max_multiple( zconv , isize )            ! max over the global domain for all the variables 
     172         ENDIF 
     173         ! 
     174         DO jk=1,isize 
     175            ptab(:,:,jk) = zrlx(:,:,jk) 
     176         END DO 
     177         ! 
     178      END DO                                       ! end of sub-time step loop 
     179 
     180     ! ----------------------- 
     181      !!! final step (clem) !!! 
     182      DO jk = 1, isize 
     183         jl = (jk-1) /( ihdf_vars+nlay_i)+1 
    100184         DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
    101185            DO ji = 1 , fs_jpim1   ! vector opt. 
    102                zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 
    103                zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 
     186               zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 
     187               zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 
    104188            END DO 
    105189         END DO 
    … …  
    108192            DO ji = fs_2 , fs_jpim1   ! vector opt.  
    109193               zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 
    110             END DO 
    111          END DO 
    112          ! 
    113          IF( iter == 1 )   zdiv0(:,:) = zdiv(:,:)        ! save the 1st evaluation of the diffusive trend in zdiv0 
    114          ! 
    115          DO jj = 2, jpjm1                                ! iterative evaluation 
    116             DO ji = fs_2 , fs_jpim1   ! vector opt. 
    117                zrlxint = (   ztab0(ji,jj)    & 
    118                   &       +  rdt_ice * (           zalfa   * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj) )   & 
    119                   &                      + ( 1.0 - zalfa ) *   zdiv0(ji,jj) )                               &  
    120                   &      ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 
    121                zrlx(ji,jj) = ptab(ji,jj) + zrelax * ( zrlxint - ptab(ji,jj) ) 
    122             END DO 
    123          END DO 
    124          CALL lbc_lnk( zrlx, 'T', 1. )                   ! lateral boundary condition 
    125          ! 
    126          IF ( MOD( iter, nn_convfrq ) == 0 )  THEN    ! convergence test every nn_convfrq iterations (perf. optimization) 
    127             zconv = 0._wp 
    128             DO jj = 2, jpjm1 
    129                DO ji = fs_2, fs_jpim1 
    130                   zconv = MAX( zconv, ABS( zrlx(ji,jj) - ptab(ji,jj) )  ) 
    131                END DO 
    132             END DO 
    133             IF( lk_mpp )   CALL mpp_max( zconv )      ! max over the global domain 
    134          ENDIF 
    135          ! 
    136          ptab(:,:) = zrlx(:,:) 
    137          ! 
    138       END DO                                       ! end of sub-time step loop 
    139  
    140       ! ----------------------- 
    141       !!! final step (clem) !!! 
    142       DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
    143          DO ji = 1 , fs_jpim1   ! vector opt. 
    144             zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 
    145             zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 
     194               ptab(ji,jj,jk) = ztab0(ji,jj,jk) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj,jk) ) 
     195            END DO 
    146196         END DO 
    147197      END DO 
    148       ! 
    149       DO jj= 2, jpjm1                                 ! diffusive trend : divergence of the fluxes 
    150          DO ji = fs_2 , fs_jpim1   ! vector opt.  
    151             zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 
    152             ptab(ji,jj) = ztab0(ji,jj) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj) ) 
    153          END DO 
    154       END DO 
    155       CALL lbc_lnk( ptab, 'T', 1. )                   ! lateral boundary condition 
     198 
     199      CALL lbc_lnk_multi( pt2d_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     200 
    156201      !!! final step (clem) !!! 
    157202      ! ----------------------- 
    158203 
    159204      IF(ln_ctl)   THEN 
    160          zrlx(:,:) = ptab(:,:) - ztab0(:,:) 
    161          WRITE(charout,FMT="(' lim_hdf  : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 
    162          CALL prt_ctl( tab2d_1=zrlx, clinfo1=charout ) 
    163       ENDIF 
    164       ! 
    165       CALL wrk_dealloc( jpi, jpj, zrlx, zflu, zflv, zdiv0, zdiv, ztab0 ) 
     205         DO jk = 1 , isize 
     206            zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk) 
     207            WRITE(charout,FMT="(' lim_hdf  : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 
     208            CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout ) 
     209         END DO 
     210      ENDIF 
     211      ! 
     212      CALL wrk_dealloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 
     213      CALL wrk_dealloc( jpi, jpj, zflu, zflv, zdiv ) 
     214 
     215      DEALLOCATE( zconv ) 
     216      DEALLOCATE( pt2d_array , zrlx_array ) 
     217      DEALLOCATE( type_array ) 
     218      DEALLOCATE( psgn_array ) 
    166219      ! 
    167220   END SUBROUTINE lim_hdf 
     221 
    168222 
    169223    
    … …  
    179233      !!------------------------------------------------------------------- 
    180234      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    181       NAMELIST/namicehdf/ nn_convfrq 
     235      NAMELIST/namicehdf/ nn_convfrq  
    182236      !!------------------------------------------------------------------- 
    183237      ! 
    … …  
    212266   !!====================================================================== 
    213267END MODULE limhdf 
     268 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90

    r6772 r7256  
    2424   USE par_oce          ! ocean parameters 
    2525   USE dom_ice          ! sea-ice domain 
     26   USE limvar           ! lim_var_salprof 
    2627   USE in_out_manager   ! I/O manager 
    2728   USE lib_mpp          ! MPP library 
    2829   USE lib_fortran      ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    2930   USE wrk_nemo         ! work arrays 
    30    USE fldread          ! read input fields 
    31    USE iom 
    3231 
    3332   IMPLICIT NONE 
    … …  
    4948   REAL(wp) ::   rn_tmi_ini_s   ! initial temperature 
    5049 
    51    INTEGER , PARAMETER ::   jpfldi    = 7           ! maximum number of files to read 
    52    INTEGER , PARAMETER ::   jp_hicif = 1           ! index of thick (m)    at T-point 
    53    INTEGER , PARAMETER ::   jp_hsnif = 2           ! index of thick (m)    at T-point 
    54    INTEGER , PARAMETER ::   jp_frld  = 3           ! index of ice fraction (%) at T-point 
    55    INTEGER , PARAMETER ::   jp_sist  = 4           ! index of ice surface temp (K)    at T-point 
    56    INTEGER , PARAMETER ::   jp_tbif1 = 5           ! index of ice temp lev1 (K) at T-point 
    57    INTEGER , PARAMETER ::   jp_tbif2 = 6           ! index of ice temp lev2 (K) at T-point 
    58    INTEGER , PARAMETER ::   jp_tbif3 = 7           ! index of ice temp lev3 (K) at T-point 
    59    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   si    ! structure of input fields (file informations, fields read) 
    60  
    61    REAL(wp),DIMENSION(:,:)  ,ALLOCATABLE :: hicif_ini,hsnif_ini,frld_ini,sist_ini, zswitch 
    62    REAL(wp),DIMENSION(:,:,:),ALLOCATABLE :: tbif_ini 
    63  
    6450   LOGICAL  ::  ln_iceini    ! initialization or not 
    65    LOGICAL  ::  ln_limini_file   ! Ice initialization state from 2D netcdf file 
    6651   !!---------------------------------------------------------------------- 
    6752   !!   LIM 3.0,  UCL-LOCEAN-IPSL (2008) 
    … …  
    10792      REAL(wp), POINTER, DIMENSION(:)     :: zht_i_ini, zat_i_ini, zvt_i_ini, zht_s_ini, zsm_i_ini, ztm_i_ini 
    10893      REAL(wp), POINTER, DIMENSION(:,:)   :: zh_i_ini, za_i_ini, zv_i_ini 
     94      REAL(wp), POINTER, DIMENSION(:,:)   :: zswitch    ! ice indicator 
    10995      INTEGER,  POINTER, DIMENSION(:,:)   :: zhemis   ! hemispheric index 
    11096      !-------------------------------------------------------------------- 
    11197 
     98      CALL wrk_alloc( jpi, jpj, zswitch ) 
    11299      CALL wrk_alloc( jpi, jpj, zhemis ) 
    113100      CALL wrk_alloc( jpl,   2, zh_i_ini,  za_i_ini,  zv_i_ini ) 
    … …  
    131118 
    132119      ! basal temperature (considered at freezing point) 
    133       t_bo(:,:) = ( eos_fzp( sss_m(:,:) ) + rt0 ) * tmask(:,:,1)  
     120      CALL eos_fzp( sss_m(:,:), t_bo(:,:) ) 
     121      t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1)  
    134122 
    135123      IF( ln_iceini ) THEN 
    … …  
    164152      ! 3) Initialization of sea ice state variables 
    165153      !-------------------------------------------------------------------- 
    166       IF( ln_limini_file )THEN 
    167  
    168          CALL limini_file 
    169  
    170       ELSE 
    171154 
    172155      !----------------------------- 
    … …  
    264247               ztest_1 = 1 
    265248            ELSE  
    266               ! this write is useful 
    267               IF(lwp)  WRITE(numout,*) ' * TEST1 AREA NOT CONSERVED *** zA_cons = ', zA_cons,' zat_i_ini = ',zat_i_ini(i_hemis)  
    268249               ztest_1 = 0 
    269250            ENDIF 
    … …  
    276257               ztest_2 = 1 
    277258            ELSE 
    278               ! this write is useful 
    279               IF(lwp)  WRITE(numout,*) ' * TEST2 VOLUME NOT CONSERVED *** zV_cons = ', zV_cons, & 
    280                             ' zvt_i_ini = ', zvt_i_ini(i_hemis) 
    281259               ztest_2 = 0 
    282260            ENDIF 
    … …  
    286264               ztest_3 = 1 
    287265            ELSE 
    288                ! this write is useful 
    289                IF(lwp) WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zh_i_ini(i_fill,i_hemis) = ', & 
    290                zh_i_ini(i_fill,i_hemis), ' hi_max(jpl-1) = ', hi_max(i_fill-1) 
    291266               ztest_3 = 0 
    292267            ENDIF 
    … …  
    296271            DO jl = 1, jpl 
    297272               IF ( za_i_ini(jl,i_hemis) .LT. 0._wp ) THEN  
    298                   ! this write is useful 
    299                   IF(lwp) WRITE(numout,*) ' * TEST 4 POSITIVITY NOT OK FOR CAT ', jl, ' WITH A = ', za_i_ini(jl,i_hemis) 
    300273                  ztest_4 = 0 
    301274               ENDIF 
    … …  
    356329      END DO 
    357330 
     331      ! for constant salinity in time 
     332      IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     333         CALL lim_var_salprof 
     334         smv_i = sm_i * v_i 
     335      ENDIF 
     336 
    358337      ! Snow temperature and heat content 
    359338      DO jk = 1, nlay_s 
    … …  
    394373 
    395374      tn_ice (:,:,:) = t_su (:,:,:) 
    396  
    397       ENDIF !ln_limini_file 
    398375 
    399376      ELSE  
    … …  
    420397            END DO 
    421398         END DO 
    422  
     399       
    423400      ENDIF ! ln_iceini 
    424401       
    … …  
    472449 
    473450 
     451      CALL wrk_dealloc( jpi, jpj, zswitch ) 
    474452      CALL wrk_dealloc( jpi, jpj, zhemis ) 
    475453      CALL wrk_dealloc( jpl,   2, zh_i_ini,  za_i_ini,  zv_i_ini ) 
    … …  
    494472      !!  8.5  ! 07-11 (M. Vancoppenolle) rewritten initialization 
    495473      !!----------------------------------------------------------------------------- 
    496       ! 
    497       INTEGER :: ios,ierr,inum_ice                 ! Local integer output status for namelist read 
    498       INTEGER :: ji,jj 
    499       INTEGER :: ifpr, ierror 
    500       ! 
    501       CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ice files 
    502       TYPE(FLD_N)                    ::   sn_hicif, sn_hsnif, sn_frld, sn_sist 
    503       TYPE(FLD_N)                    ::   sn_tbif1, sn_tbif2, sn_tbif3 
    504       TYPE(FLD_N), DIMENSION(jpfldi) ::   slf_i                 ! array of namelist informations on the fields to read 
    505       ! 
    506       NAMELIST/namiceini/ ln_iceini, ln_limini_file, rn_thres_sst, rn_hts_ini_n, rn_hts_ini_s,  & 
    507          &                rn_hti_ini_n, rn_hti_ini_s, rn_ati_ini_n, rn_ati_ini_s, rn_smi_ini_n, & 
    508          &                rn_smi_ini_s, rn_tmi_ini_n, rn_tmi_ini_s,                             & 
    509          &                sn_hicif, sn_hsnif, sn_frld, sn_sist,                                 & 
    510          &                sn_tbif1, sn_tbif2, sn_tbif3, cn_dir 
     474      NAMELIST/namiceini/ ln_iceini, rn_thres_sst, rn_hts_ini_n, rn_hts_ini_s, rn_hti_ini_n, rn_hti_ini_s,  & 
     475         &                                      rn_ati_ini_n, rn_ati_ini_s, rn_smi_ini_n, rn_smi_ini_s, rn_tmi_ini_n, rn_tmi_ini_s 
     476      INTEGER :: ios                 ! Local integer output status for namelist read 
    511477      !!----------------------------------------------------------------------------- 
    512478      ! 
    … …  
    520486      IF(lwm) WRITE ( numoni, namiceini ) 
    521487 
    522       slf_i(jp_hicif) = sn_hicif  ;  slf_i(jp_hsnif) = sn_hsnif 
    523       slf_i(jp_frld)  = sn_frld   ;  slf_i(jp_sist)  = sn_sist 
    524       slf_i(jp_tbif1) = sn_tbif1  ;  slf_i(jp_tbif2) = sn_tbif2  ; slf_i(jp_tbif3) = sn_tbif3 
    525  
    526488      ! Define the initial parameters 
    527489      ! ------------------------- 
    … …  
    532494         WRITE(numout,*) '~~~~~~~~~~~~~~~' 
    533495         WRITE(numout,*) '   initialization with ice (T) or not (F)       ln_iceini     = ', ln_iceini 
    534          WRITE(numout,*) '   initialization with ice (T) or not (F)   ln_limini_file  = ', ln_limini_file 
    535496         WRITE(numout,*) '   threshold water temp. for initial sea-ice    rn_thres_sst  = ', rn_thres_sst 
    536497         WRITE(numout,*) '   initial snow thickness in the north          rn_hts_ini_n  = ', rn_hts_ini_n 
    … …  
    546507      ENDIF 
    547508 
    548       IF( ln_limini_file ) THEN                      ! Ice initialization using input file 
    549          ! 
    550          ierr = alloc_lim_istate_init() 
    551          ! 
    552 !         CALL iom_open( 'Ice_initialization.nc', inum_ice ) 
    553 !         ! 
    554 !         IF( inum_ice > 0 ) THEN 
    555 !            IF(lwp) WRITE(numout,*) 
    556 !            IF(lwp) WRITE(numout,*) '                  ice state initialization with : Ice_initialization.nc' 
    557 ! 
    558 !            CALL iom_get( inum_ice, jpdom_data, 'hicif', hicif_ini ) 
    559 !            CALL iom_get( inum_ice, jpdom_data, 'hsnif', hsnif_ini ) 
    560 !            CALL iom_get( inum_ice, jpdom_data, 'frld' , frld_ini  ) 
    561 !            CALL iom_get( inum_ice, jpdom_data, 'ts'   , sist_ini  ) 
    562 !            CALL iom_get( inum_ice, jpdom_unknown, 'tbif', tbif_ini(1:nlci,1:nlcj,:),   & 
    563 !                 &        kstart = (/ mig(1),mjg(1),1 /), kcount = (/ nlci,nlcj,3 /) ) 
    564 !            ! put some values in the extra-halo... 
    565  
    566          ! set si structure 
    567          ALLOCATE( si(jpfldi), STAT=ierror ) 
    568          IF( ierror > 0 ) THEN 
    569             CALL ctl_stop( 'Ice_ini in limistate: unable to allocate si structure' )   ;   RETURN 
    570          ENDIF 
    571  
    572          DO ifpr= 1, jpfldi 
    573             ALLOCATE( si(ifpr)%fnow(jpi,jpj,1) ) 
    574             ALLOCATE( si(ifpr)%fdta(jpi,jpj,1,2) ) 
    575          END DO 
    576  
    577          ! fill si with slf_i and control print 
    578          CALL fld_fill( si, slf_i, cn_dir, 'lim_istate', 'lim istate ini', 'numnam_ice' ) 
    579  
    580          CALL fld_read( nit000, 1, si )                ! input fields provided at the current time-step 
    581  
    582          hicif_ini(:,:)  = si(jp_hicif)%fnow(:,:,1) 
    583          hsnif_ini(:,:)  = si(jp_hsnif)%fnow(:,:,1) 
    584          frld_ini(:,:)   = si(jp_frld)%fnow(:,:,1) 
    585          sist_ini(:,:)   = si(jp_sist)%fnow(:,:,1) 
    586          tbif_ini(:,:,1) = si(jp_tbif1)%fnow(:,:,1) 
    587          tbif_ini(:,:,2) = si(jp_tbif2)%fnow(:,:,1) 
    588          tbif_ini(:,:,3) = si(jp_tbif3)%fnow(:,:,1) 
    589  
    590          DO jj = nlcj+1, jpj   ;   tbif_ini(1:nlci,jj,:) = tbif_ini(1:nlci,nlej,:)   ;   END DO 
    591          DO ji = nlci+1, jpi   ;   tbif_ini(ji    ,: ,:) = tbif_ini(nlei  ,:   ,:)   ;   END DO 
    592  
    593 !            CALL iom_close( inum_ice) 
    594 !            ! 
    595 !         ENDIF 
    596       ENDIF 
    597  
    598509   END SUBROUTINE lim_istate_init 
    599510 
    600    SUBROUTINE limini_file 
    601       !!----------------------------------------------------------------------------- 
    602       !! 
    603       !! 
    604       !! 
    605       !! 
    606       !!----------------------------------------------------------------------------- 
    607       INTEGER    :: jl,ji,jj,jk 
    608       INTEGER    :: jl0 
    609       INTEGER    :: i_fill,jit,jjt 
    610       REAL(wp)   :: ztest_1, ztest_2, ztest_3, ztest_4, ztests, zsigma, zarg, zA, zV, zA_cons, zV_cons, zconv,zH 
    611       REAL(wp)   :: eps=1.e-6 
    612       REAL(wp)   :: zmin,zmax 
    613       !rbb REAL(wp)   :: epsi20,ztmelts,zdh 
    614       REAL(wp)   ::ztmelts,zdh 
    615  
    616       REAL(wp), POINTER, DIMENSION(:,:)   :: zhm_i_ini, zat_i_ini, zvt_i_ini, zhm_s_ini, zsm_i_ini 
    617       REAL(wp), POINTER, DIMENSION(:,:,:) :: zv_i_ini 
    618       REAL(wp), POINTER, DIMENSION(:,:,:) :: zht_i_ini,za_i_ini 
    619       REAL(wp), POINTER, DIMENSION(:,:)   :: zidto    ! ice indicator 
    620        !----------------------------------------------------------------------------- 
    621       IF(lwp)WRITE(numout,*)"limistate: read file : " 
    622  
    623       CALL wrk_alloc(jpl,jpi,jpj, zv_i_ini) 
    624       CALL wrk_alloc(    jpi,jpj, zhm_i_ini, zat_i_ini, zvt_i_ini, zhm_s_ini, zsm_i_ini ) 
    625       CALL wrk_alloc(    jpl,jpi,jpj,zht_i_ini,za_i_ini) 
    626       CALL wrk_alloc(    jpi,jpj,zidto ) 
    627  
    628       zhm_i_ini(:,:) = hicif_ini(:,:)  ! ice thickness 
    629       zat_i_ini(:,:) = 1._wp - frld_ini(:,:)   ! ice concentration 
    630       zvt_i_ini(:,:) = zhm_i_ini(:,:) * zat_i_ini(:,:)   ! ice volume 
    631       zhm_s_ini(:,:) = hsnif_ini(:,:)  ! snow depth 
    632  
    633       zht_i_ini(:,:,:) = 0._wp 
    634       za_i_ini(:,:,:) = 0._wp 
    635       zv_i_ini(:,:,:) = 0._wp 
    636  
    637       zat_i_ini(:,:) = MIN( zat_i_ini(:,:) , 1.0_wp ) 
    638  
    639  
    640       DO ji = 1, jpi 
    641       DO jj = 1, jpj 
    642  
    643          IF( zat_i_ini(ji,jj) .GT. 0._wp .AND. zhm_i_ini(ji,jj) .GT. 0._wp )THEN 
    644  
    645  
    646             IF( gphit(ji,jj) .GE. 0._wp )THEN ; zsm_i_ini(ji,jj) = rn_smi_ini_n 
    647             ELSE                              ; zsm_i_ini(ji,jj) = rn_smi_ini_s 
    648             ENDIF 
    649  
    650             jl0 = 1 
    651             DO jl = 2, jpl 
    652                IF ( ( zhm_i_ini(ji,jj) .GT. hi_max(jl-1) ) .AND. & 
    653                   (   zhm_i_ini(ji,jj) .LE. hi_max(jl)   )       ) THEN 
    654                jl0 = jl 
    655                ENDIF 
    656             END DO 
    657  
    658             IF( jl0==1 )THEN 
    659  
    660                zht_i_ini(1,ji,jj)       = zhm_i_ini(ji,jj) 
    661                za_i_ini(1,ji,jj)        = zat_i_ini(ji,jj) 
    662                zht_i_ini(2:jpl,ji,jj)   = 0._wp 
    663                za_i_ini(2:jpl,ji,jj)    = 0._wp 
    664  
    665             ELSE ! jl0 ne 1 
    666                ztest_1 = 0 ; ztest_2 = 0 ; ztest_3 = 0 ; ztest_4 = 0 
    667  
    668                DO i_fill = jpl, 1, -1 
    669                   IF( ( ztest_1 + ztest_2 + ztest_3 + ztest_4 ) .NE. 4 ) THEN 
    670  
    671                      !---------------------------- 
    672                      ! fill the i_fill categories 
    673                      !---------------------------- 
    674                      ! *** 1 category to fill 
    675                      IF( i_fill .EQ. 1 ) THEN 
    676                         zht_i_ini(1,ji,jj)       = zhm_i_ini(ji,jj) 
    677                         za_i_ini(1,ji,jj)        = zat_i_ini(ji,jj) 
    678                         zht_i_ini(2:jpl,ji,jj)   = 0._wp 
    679                         za_i_ini(2:jpl,ji,jj)    = 0._wp 
    680                      ELSE 
    681  
    682                         ! *** >1 categores to fill 
    683                         !--- Ice thicknesses in the i_fill - 1 first categories 
    684                         DO jl = 1, i_fill - 1 
    685                            zht_i_ini(jl,ji,jj)    = 0.5 * ( hi_max(jl) + hi_max(jl-1) ) 
    686                         END DO 
    687  
    688                         !--- jl0: most likely index where cc will be maximum 
    689                         DO jl = 1, jpl 
    690                         IF ( ( zhm_i_ini(ji,jj) .GT. hi_max(jl-1) ) .AND. & 
    691                               ( zhm_i_ini(ji,jj) .LE. hi_max(jl)   ) ) THEN 
    692                             jl0 = jl 
    693                         ENDIF 
    694                         END DO 
    695                         jl0 = MIN(jl0, i_fill) 
    696  
    697                         !--- Concentrations 
    698                         za_i_ini(jl0,ji,jj)      = zat_i_ini(ji,jj) / SQRT(REAL(jpl)) 
    699                         DO jl = 1, i_fill - 1 
    700                         IF ( jl .NE. jl0 ) THEN 
    701                              zsigma               = 0.5 * zhm_i_ini(ji,jj) 
    702                              zarg                 = ( zht_i_ini(jl,ji,jj) - zhm_i_ini(ji,jj) ) / zsigma 
    703                              za_i_ini(jl,ji,jj) = za_i_ini(jl0,ji,jj) * EXP(-zarg**2) 
    704                         ENDIF 
    705                         END DO 
    706  
    707                         zA = 0. ! sum of the areas in the jpl categories 
    708                         DO jl = 1, i_fill - 1 
    709                            zA = zA + za_i_ini(jl,ji,jj) 
    710                         END DO 
    711                         za_i_ini(i_fill,ji,jj)   = zat_i_ini(ji,jj) - zA ! ice conc in the last category 
    712                         IF ( i_fill .LT. jpl ) za_i_ini(i_fill+1:jpl, ji,jj) = 0._wp 
    713  
    714                         !--- Ice thickness in the last category 
    715                         zV = 0. ! sum of the volumes of the N-1 categories 
    716                         DO jl = 1, i_fill - 1 
    717                            zV = zV + za_i_ini(jl,ji,jj)*zht_i_ini(jl,ji,jj) 
    718                         END DO 
    719                         zht_i_ini(i_fill,ji,jj) = ( zvt_i_ini(ji,jj) - zV ) /za_i_ini(i_fill,ji,jj) 
    720                         IF ( i_fill .LT. jpl ) zht_i_ini(i_fill+1:jpl, ji,jj) = 0._wp 
    721  
    722                         !--- volumes 
    723                         zv_i_ini(:,ji,jj) = za_i_ini(:,ji,jj) * zht_i_ini(:,ji,jj) 
    724                         IF ( i_fill .LT. jpl ) zv_i_ini(i_fill+1:jpl, ji,jj) = 0._wp 
    725  
    726                      ENDIF ! i_fill 
    727  
    728                      !--------------------- 
    729                      ! Compatibility tests 
    730                      !--------------------- 
    731                      ! Test 1: area conservation 
    732                      zA_cons = SUM(za_i_ini(:,ji,jj)) ; zconv = ABS(zat_i_ini(ji,jj) - zA_cons ) 
    733                      IF ( zconv .LT. 1.0e-6 ) THEN 
    734                         ztest_1 = 1 
    735                      ELSE 
    736                       ! this write is useful 
    737                       !WRITE(numout,*) ' * TEST1 AREA NOT CONSERVED *** zA_cons = ', zA_cons,' zat_i_ini = ',zat_i_ini(ji,jj) 
    738                       !WRITE(numout,*) 'ji,jj,narea ',ji,jj,narea 
    739                       !WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj) 
    740                       !WRITE(numout,*) ' zhm_i_ini : ', zhm_i_ini(ji,jj) 
    741                       !WRITE(numout,*) ' zht_i_ini(:,jij,jj) ',zht_i_ini(:,ji,jj) 
    742                       !WRITE(numout,*) ' za_i_ini(:,jij,jj) ',za_i_ini(:,ji,jj) 
    743                       !WRITE(numout,*) ' hi_max ',hi_max 
    744                       !WRITE(numout,*) ' jl0 = ',jl0 
    745                       !WRITE(numout,*) ' vol = ',zvt_i_ini(ji,jj),SUM(zv_i_ini(:,ji,jj)) 
    746                       ztest_1 = 0 
    747                      ENDIF 
    748  
    749                      ! Test 2: volume conservation 
    750                      zV_cons = SUM(zv_i_ini(:,ji,jj)) 
    751                      zconv = ABS(zvt_i_ini(ji,jj) - zV_cons) 
    752  
    753                      IF ( zconv .LT. 1.0e-6 ) THEN 
    754                         ztest_2 = 1 
    755                      ELSE 
    756                         ! this write is useful 
    757                         !WRITE(numout,*) ' * TEST2 VOLUME NOT CONSERVED *** zV_cons = ', zV_cons, & 
    758                         !    ' zvt_i_ini = ', zvt_i_ini(ji,jj) 
    759                         !WRITE(numout,*) 'ji,jj,narea ',ji,jj,narea 
    760                         !WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj) 
    761                         !WRITE(numout,*) ' zhm_i_ini : ', zhm_i_ini(ji,jj) 
    762                         !WRITE(numout,*) ' zht_i_ini(:,jij,jj) ',zht_i_ini(:,ji,jj) 
    763                         !WRITE(numout,*) ' za_i_ini(:,jij,jj) ',za_i_ini(:,ji,jj) 
    764                         !WRITE(numout,*) ' hi_max ',hi_max 
    765                         !WRITE(numout,*) ' jl0 = ',jl0 
    766                         ztest_2 = 0 
    767                      ENDIF 
    768  
    769                      ! Test 3: thickness of the last category is in-bounds ?  
    770                      IF ( zht_i_ini(i_fill, ji,jj) .GT. hi_max(i_fill-1) ) THEN 
    771                      ztest_3 = 1 
    772                      ELSE 
    773                      ! this write is useful 
    774                      !WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zht_i_ini(i_fill,ji,jj) = ', & 
    775                      !zht_i_ini(i_fill,ji,jj), ' hi_max(jpl-1) = ', hi_max(i_fill-1) 
    776                      !WRITE(numout,*) 'ji,jj,narea ',ji,jj,narea 
    777                      !WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj) 
    778                      !WRITE(numout,*) ' zhm_i_ini : ', zhm_i_ini(ji,jj) 
    779                      !WRITE(numout,*) ' zht_i_ini(:,jij,jj) ',zht_i_ini(:,ji,jj) 
    780                      !WRITE(numout,*) ' za_i_ini(:,jij,jj) ',za_i_ini(:,ji,jj) 
    781                      !WRITE(numout,*) ' hi_max ',hi_max 
    782                      !WRITE(numout,*) ' jl0 = ',jl0 
    783                      ztest_3 = 0 
    784                      ENDIF 
    785  
    786                      ! Test 4: positivity of ice concentrations 
    787                      ztest_4 = 1 
    788                      DO jl = 1, jpl 
    789                      IF ( za_i_ini(jl,ji,jj) .LT. 0._wp ) THEN 
    790                         ! this write is useful 
    791                         !WRITE(numout,*) ' * TEST 4 POSITIVITY NOT OK FOR CAT ', jl, 'WITH A = ', za_i_ini(jl,ji,jj) 
    792                         !WRITE(numout,*) 'ji,jj,narea ',ji,jj,narea 
    793                         !WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj) 
    794                         !WRITE(numout,*) ' zhm_i_ini : ', zhm_i_ini(ji,jj) 
    795                         !WRITE(numout,*) ' zht_i_ini(:,jij,jj) ',zht_i_ini(:,ji,jj) 
    796                         !WRITE(numout,*) ' za_i_ini(:,jij,jj) ',za_i_ini(:,ji,jj) 
    797                         !WRITE(numout,*) ' hi_max ',hi_max 
    798                         !WRITE(numout,*) ' jl0 = ',jl0 
    799                         !WRITE(numout,*) 
    800                         ztest_4 = 0 
    801                      ENDIF 
    802                      END DO 
    803  
    804                   ENDIF ! ztest_1 + ztest_2 + ztest_3 + ztest_4 
    805  
    806                   ztests = ztest_1 + ztest_2 + ztest_3 + ztest_4 
    807  
    808                END DO ! i_fill 
    809  
    810                !WRITE(numout,*) ' ztests : ', ztests 
    811                !IF ( ztests .NE. 4 ) THEN 
    812                !WRITE(numout,*) 
    813                !WRITE(numout,*) ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ' 
    814                !WRITE(numout,*) ' !!!! RED ALERT                  !!! ' 
    815                !WRITE(numout,*) ' !!!! BIIIIP BIIIP BIIIIP BIIIIP !!!' 
    816                !WRITE(numout,*) ' !!!! Something is wrong in the LIM3 initialization procedure ' 
    817                !WRITE(numout,*) ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ' 
    818                !WRITE(numout,*) 'ji,jj,narea ',ji,jj,narea 
    819                !WRITE(numout,*) ' *** ztests is not equal to 4 ' 
    820                !WRITE(numout,*) ' *** ztest_i (i=1,4) = ', ztest_1, ztest_2,ztest_3,ztest_4 
    821                !WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj) 
    822                !WRITE(numout,*) ' zhm_i_ini : ', zhm_i_ini(ji,jj) 
    823                !WRITE(numout,*) ' zht_i_ini(:,jij,jj) ',zht_i_ini(:,ji,jj) 
    824                !WRITE(numout,*) ' za_i_ini(:,jij,jj) ',za_i_ini(:,ji,jj) 
    825                !WRITE(numout,*) ' hi_max ',hi_max 
    826                !ENDIF ! ztests .NE. 4 
    827  
    828             ENDIF  !  jl0 ne 1 
    829  
    830          ENDIF  !  zat_i_ini ne 0 
    831       END DO ! jj 
    832       END DO ! ji 
    833  
    834  
    835       !--------------------------------------------------------------------- 
    836       ! 3.3) Space-dependent arrays for ice state variables 
    837       !--------------------------------------------------------------------- 
    838  
    839       ! Ice concentration, thickness and volume, ice salinity, ice age, surface 
    840       ! temperature 
    841       DO jl = 1, jpl ! loop over categories 
    842          DO jj = 1, jpj 
    843             DO ji = 1, jpi 
    844                a_i(ji,jj,jl)   = zswitch(ji,jj) * za_i_ini (jl,ji,jj)  ! concentration 
    845                ht_i(ji,jj,jl)  = zswitch(ji,jj) * zht_i_ini(jl,ji,jj)   !ice thickness 
    846  
    847                IF( zhm_i_ini( ji,jj ) .GT. 0_wp )THEN ; ht_s(ji,jj,jl)  = ht_i(ji,jj,jl) * ( zhm_s_ini( ji,jj ) / zhm_i_ini( ji,jj ) ) 
    848                ELSE                                   ; ht_s(ji,jj,jl)  = 0._wp 
    849                ENDIF 
    850                sm_i(ji,jj,jl)  = zswitch(ji,jj) * zsm_i_ini(ji,jj) !+ (1._wp - zswitch(ji,jj) ) * rn_simin ! salinity 
    851                o_i(ji,jj,jl)   = zswitch(ji,jj) * 1._wp + ( 1._wp -zswitch(ji,jj) ) ! age 
    852                t_su(ji,jj,jl)  = sist_ini(ji,jj) 
    853  
    854                ! This case below should not be used if (ht_s/ht_i) is ok in 
    855                ! namelist 
    856                ! In case snow load is in excess that would lead to 
    857                ! transformation from snow to ice 
    858                ! Then, transfer the snow excess into the ice (different from 
    859                ! limthd_dh) 
    860                zdh = MAX( 0._wp, ( rhosn * ht_s(ji,jj,jl) + ( rhoic - rau0 ) *ht_i(ji,jj,jl) ) * r1_rau0 ) 
    861                ! recompute ht_i, ht_s avoiding out of bounds values 
    862                ht_i(ji,jj,jl) = MIN( hi_max(jl), ht_i(ji,jj,jl) + zdh ) 
    863                ht_s(ji,jj,jl) = MAX( 0._wp, ht_s(ji,jj,jl) - zdh * rhoic *r1_rhosn ) 
    864  
    865                ! ice volume, salt content, age content 
    866                v_i(ji,jj,jl)   = ht_i(ji,jj,jl) * a_i(ji,jj,jl)              !ice volume 
    867                v_s(ji,jj,jl)   = ht_s(ji,jj,jl) * a_i(ji,jj,jl)              !snow volume 
    868                smv_i(ji,jj,jl) = MIN( sm_i(ji,jj,jl) , sss_m(ji,jj) ) *v_i(ji,jj,jl) ! salt content 
    869                oa_i(ji,jj,jl)  = o_i(ji,jj,jl) * a_i(ji,jj,jl)               !age content 
    870             END DO ! ji 
    871          END DO ! jj 
    872       END DO ! jl 
    873  
    874       !cbr 
    875       DO jk = 1, nlay_s 
    876          DO  jl = 1, jpl ! loop over categories 
    877             !rbb t_s(:,:,1,jl) =  tbif_ini(:,:,1) 
    878             t_s(:,:,1,jl) =  tbif_ini(:,:,1)*zswitch(:,:)+ ( 1._wp - zswitch(:,:) ) * rt0 
    879          END DO ! jl 
    880       END DO ! jk 
    881  
    882       ! Snow temperature and heat content 
    883       DO jk = 1, nlay_s 
    884          DO jl = 1, jpl ! loop over categories 
    885             DO jj = 1, jpj 
    886                DO ji = 1, jpi 
    887 !cbr???                   t_s(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * rt0 
    888                    ! Snow energy of melting 
    889                    e_s(ji,jj,jk,jl) = zswitch(ji,jj) * rhosn * ( cpic * ( rt0 - t_s(ji,jj,jk,jl) ) + lfus ) 
    890  
    891                    ! Mutliply by volume, and divide by number of layers to get 
    892                    ! heat content in J/m2 
    893                    e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * v_s(ji,jj,jl) *r1_nlay_s 
    894                END DO ! ji 
    895             END DO ! jj 
    896          END DO ! jl 
    897       END DO ! jk 
    898  
    899       ! Ice salinity, temperature and heat content 
    900       DO  jk = 1, nlay_i 
    901          DO jl = 1, jpl ! loop over categories 
    902             DO jj = 1, jpj 
    903                DO ji = 1, jpi 
    904 !cbr???                   t_i(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * rt0 
    905                    t_i(ji,jj,jk,jl) =  tbif_ini(ji,jj,2)*zswitch(ji,jj)+ ( 1._wp - zswitch(ji,jj) ) * rt0 
    906                    s_i(ji,jj,jk,jl) = zswitch(ji,jj) * zsm_i_ini(ji,jj) !+ ( 1._wp - zswitch(ji,jj) ) * rn_simin 
    907                    ztmelts          = - tmut * s_i(ji,jj,jk,jl) + rt0           !Melting temperature in K 
    908  
    909                    ! heat content per unit volume 
    910                    e_i(ji,jj,jk,jl) = zswitch(ji,jj) * rhoic * (   cpic    * ( ztmelts - t_i(ji,jj,jk,jl) ) & 
    911                       +   lfus    * ( 1._wp - (ztmelts-rt0) /MIN((t_i(ji,jj,jk,jl)-rt0),-epsi20) ) & 
    912                       -   rcp     * ( ztmelts - rt0 ) ) 
    913  
    914                    ! Mutliply by ice volume, and divide by number of layers to 
    915                    ! get heat content in J/m2 
    916                    e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * v_i(ji,jj,jl) * r1_nlay_i 
    917                END DO ! ji 
    918             END DO ! jj 
    919          END DO ! jl 
    920       END DO ! jk 
    921  
    922       !cbr tmp CALL wrk_dealloc(jpl,jpi,jpj, zht_i_ini, za_i_ini, zv_i_ini) 
    923       CALL wrk_dealloc(jpl,jpi,jpj, zv_i_ini) 
    924       CALL wrk_dealloc(    jpl,jpi,jpj,zht_i_ini,za_i_ini) 
    925       CALL wrk_dealloc(    jpi,jpj, zhm_i_ini, zat_i_ini, zvt_i_ini, zhm_s_ini,zsm_i_ini ) 
    926       CALL wrk_dealloc(    jpi,jpj,zidto ) 
    927  
    928   END SUBROUTINE limini_file 
    929  
    930  
    931   INTEGER FUNCTION alloc_lim_istate_init() 
    932       !!----------------------------------------------------------------------------- 
    933       !! 
    934       !! 
    935       !! 
    936       !! 
    937       !!----------------------------------------------------------------------------- 
    938       INTEGER :: ierr(1) 
    939       !!----------------------------------------------------------------------------- 
    940       ALLOCATE( hicif_ini(jpi,jpj) , hsnif_ini(jpi,jpj) , frld_ini(jpi,jpj) , sist_ini(jpi,jpj) , zswitch(jpi,jpj) , tbif_ini(jpi,jpj,3) , Stat=ierr(1) ) 
    941       alloc_lim_istate_init = MAXVAL(ierr) 
    942       IF( alloc_lim_istate_init /= 0 )   CALL ctl_warn( 'lim_istate_init: failed to allocate arrays') 
    943  
    944    END FUNCTION alloc_lim_istate_init 
    945511#else 
    946512   !!---------------------------------------------------------------------- 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90

    r5602 r7256  
    4545   REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   asum     ! sum of total ice and open water area 
    4646   REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   aksum    ! ratio of area removed to area ridged 
    47    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   athorn   ! participation function; fraction of ridging/ 
    48    !                                                     ! closing associated w/ category n 
     47   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   athorn   ! participation function; fraction of ridging/closing associated w/ category n 
    4948   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   hrmin    ! minimum ridge thickness 
    5049   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   hrmax    ! maximum ridge thickness 
    5150   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   hraft    ! thickness of rafted ice 
    52    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   krdg     ! mean ridge thickness/thickness of ridging ice  
     51   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   krdg     ! thickness of ridging ice / mean ridge thickness 
    5352   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   aridge   ! participating ice ridging 
    5453   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   araft    ! participating ice rafting 
    5554 
    5655   REAL(wp), PARAMETER ::   krdgmin = 1.1_wp    ! min ridge thickness multiplier 
    57    REAL(wp), PARAMETER ::   kraft   = 2.0_wp    ! rafting multipliyer 
    58    REAL(wp), PARAMETER ::   kamax   = 1.0_wp    ! max of ice area authorized (clem: scheme is not stable if kamax <= 0.99) 
     56   REAL(wp), PARAMETER ::   kraft   = 0.5_wp    ! rafting multipliyer 
    5957 
    6058   REAL(wp) ::   Cp                             !  
    6159   ! 
    62    !----------------------------------------------------------------------- 
    63    ! Ridging diagnostic arrays for history files 
    64    !----------------------------------------------------------------------- 
    65    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   dardg1dt   ! rate of fractional area loss by ridging ice (1/s) 
    66    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   dardg2dt   ! rate of fractional area gain by new ridges (1/s) 
    67    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   dvirdgdt   ! rate of ice volume ridged (m/s) 
    68    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   opening    ! rate of opening due to divergence/shear (1/s) 
    6960   ! 
    7061   !!---------------------------------------------------------------------- 
    … …  
    8374         &      asum (jpi,jpj)     , athorn(jpi,jpj,0:jpl)                    ,     & 
    8475         &      aksum(jpi,jpj)                                                ,     & 
    85          ! 
    8676         &      hrmin(jpi,jpj,jpl) , hraft(jpi,jpj,jpl) , aridge(jpi,jpj,jpl) ,     & 
    87          &      hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) ,     & 
    88          ! 
    89          !* Ridging diagnostic arrays for history files 
    90          &      dardg1dt(jpi,jpj)  , dardg2dt(jpi,jpj)                        ,     &  
    91          &      dvirdgdt(jpi,jpj)  , opening(jpi,jpj)                         , STAT=lim_itd_me_alloc ) 
     77         &      hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) , STAT=lim_itd_me_alloc ) 
    9278         ! 
    9379      IF( lim_itd_me_alloc /= 0 )   CALL ctl_warn( 'lim_itd_me_alloc: failed to allocate arrays' ) 
    … …  
    132118      REAL(wp), POINTER, DIMENSION(:,:)   ::   opning          ! rate of opening due to divergence/shear 
    133119      REAL(wp), POINTER, DIMENSION(:,:)   ::   closing_gross   ! rate at which area removed, not counting area of new ridges 
    134       REAL(wp), POINTER, DIMENSION(:,:)   ::   msnow_mlt       ! mass of snow added to ocean (kg m-2) 
    135       REAL(wp), POINTER, DIMENSION(:,:)   ::   esnow_mlt       ! energy needed to melt snow in ocean (J m-2) 
    136       REAL(wp), POINTER, DIMENSION(:,:)   ::   vt_i_init, vt_i_final  !  ice volume summed over categories 
    137120      ! 
    138121      INTEGER, PARAMETER ::   nitermax = 20     
    … …  
    142125      IF( nn_timing == 1 )  CALL timing_start('limitd_me') 
    143126 
    144       CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross, msnow_mlt, esnow_mlt, vt_i_init, vt_i_final ) 
     127      CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross ) 
    145128 
    146129      IF(ln_ctl) THEN 
    … …  
    154137      IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_me', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    155138 
    156       CALL lim_var_zapsmall 
    157       CALL lim_var_glo2eqv            ! equivalent variables, requested for rafting 
    158  
    159139      !-----------------------------------------------------------------------------! 
    160140      ! 1) Thickness categories boundaries, ice / o.w. concentrations, init_ons 
    … …  
    164144      CALL lim_itd_me_ridgeprep                                    ! prepare ridging 
    165145      ! 
    166       IF( con_i)   CALL lim_column_sum( jpl, v_i, vt_i_init )      ! conservation check 
    167146 
    168147      DO jj = 1, jpj                                     ! Initialize arrays. 
    169148         DO ji = 1, jpi 
    170             msnow_mlt(ji,jj) = 0._wp 
    171             esnow_mlt(ji,jj) = 0._wp 
    172             dardg1dt (ji,jj) = 0._wp 
    173             dardg2dt (ji,jj) = 0._wp 
    174             dvirdgdt (ji,jj) = 0._wp 
    175             opening  (ji,jj) = 0._wp 
    176149 
    177150            !-----------------------------------------------------------------------------! 
    … …  
    204177            ! If divu_adv < 0, make sure the closing rate is large enough 
    205178            ! to give asum = 1.0 after ridging. 
    206  
    207             divu_adv(ji,jj) = ( kamax - asum(ji,jj) ) * r1_rdtice  ! asum found in ridgeprep 
     179             
     180            divu_adv(ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice  ! asum found in ridgeprep 
    208181 
    209182            IF( divu_adv(ji,jj) < 0._wp )   closing_net(ji,jj) = MAX( closing_net(ji,jj), -divu_adv(ji,jj) ) 
    … …  
    224197      DO WHILE ( iterate_ridging > 0 .AND. niter < nitermax ) 
    225198 
     199         ! 3.2 closing_gross 
     200         !-----------------------------------------------------------------------------! 
     201         ! Based on the ITD of ridging and ridged ice, convert the net 
     202         !  closing rate to a gross closing rate.   
     203         ! NOTE: 0 < aksum <= 1 
     204         closing_gross(:,:) = closing_net(:,:) / aksum(:,:) 
     205 
     206         ! correction to closing rate and opening if closing rate is excessive 
     207         !--------------------------------------------------------------------- 
     208         ! Reduce the closing rate if more than 100% of the open water  
     209         ! would be removed.  Reduce the opening rate proportionately. 
    226210         DO jj = 1, jpj 
    227211            DO ji = 1, jpi 
    228  
    229                ! 3.2 closing_gross 
    230                !-----------------------------------------------------------------------------! 
    231                ! Based on the ITD of ridging and ridged ice, convert the net 
    232                !  closing rate to a gross closing rate.   
    233                ! NOTE: 0 < aksum <= 1 
    234                closing_gross(ji,jj) = closing_net(ji,jj) / aksum(ji,jj) 
    235  
    236                ! correction to closing rate and opening if closing rate is excessive 
    237                !--------------------------------------------------------------------- 
    238                ! Reduce the closing rate if more than 100% of the open water  
    239                ! would be removed.  Reduce the opening rate proportionately. 
    240                za   = athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice 
    241                IF( za > epsi20 ) THEN 
    242                   zfac = MIN( 1._wp, ato_i(ji,jj) / za ) 
    243                   closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 
    244                   opning       (ji,jj) = opning       (ji,jj) * zfac 
     212               za   = ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice 
     213               IF( za < 0._wp .AND. za > - ato_i(ji,jj) ) THEN  ! would lead to negative ato_i 
     214                  zfac = - ato_i(ji,jj) / za 
     215                  opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) - ato_i(ji,jj) * r1_rdtice  
     216               ELSEIF( za > 0._wp .AND. za > ( asum(ji,jj) - ato_i(ji,jj) ) ) THEN  ! would lead to ato_i > asum 
     217                  zfac = ( asum(ji,jj) - ato_i(ji,jj) ) / za 
     218                  opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) + ( asum(ji,jj) - ato_i(ji,jj) ) * r1_rdtice  
    245219               ENDIF 
    246  
    247220            END DO 
    248221         END DO 
    … …  
    256229               DO ji = 1, jpi 
    257230                  za = athorn(ji,jj,jl) * closing_gross(ji,jj) * rdt_ice 
    258                   IF( za  >  epsi20 ) THEN 
    259                      zfac = MIN( 1._wp, a_i(ji,jj,jl) / za ) 
     231                  IF( za  >  a_i(ji,jj,jl) ) THEN 
     232                     zfac = a_i(ji,jj,jl) / za 
    260233                     closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 
    261                      opning       (ji,jj) = opning       (ji,jj) * zfac 
    262234                  ENDIF 
    263235               END DO 
    … …  
    268240         !-----------------------------------------------------------------------------! 
    269241 
    270          CALL lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt ) 
    271  
     242         CALL lim_itd_me_ridgeshift( opning, closing_gross ) 
     243 
     244          
    272245         ! 3.4 Compute total area of ice plus open water after ridging. 
    273246         !-----------------------------------------------------------------------------! 
    274247         ! This is in general not equal to one because of divergence during transport 
    275          asum(:,:) = ato_i(:,:) 
    276          DO jl = 1, jpl 
    277             asum(:,:) = asum(:,:) + a_i(:,:,jl) 
    278          END DO 
     248         asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 
    279249 
    280250         ! 3.5 Do we keep on iterating ??? 
    … …  
    284254 
    285255         iterate_ridging = 0 
    286  
    287256         DO jj = 1, jpj 
    288257            DO ji = 1, jpi 
    289                IF (ABS(asum(ji,jj) - kamax ) < epsi10) THEN 
     258               IF( ABS( asum(ji,jj) - 1._wp ) < epsi10 ) THEN 
    290259                  closing_net(ji,jj) = 0._wp 
    291260                  opning     (ji,jj) = 0._wp 
    292261               ELSE 
    293262                  iterate_ridging    = 1 
    294                   divu_adv   (ji,jj) = ( kamax - asum(ji,jj) ) * r1_rdtice 
     263                  divu_adv   (ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice 
    295264                  closing_net(ji,jj) = MAX( 0._wp, -divu_adv(ji,jj) ) 
    296265                  opning     (ji,jj) = MAX( 0._wp,  divu_adv(ji,jj) ) 
    … …  
    309278 
    310279         IF( iterate_ridging == 1 ) THEN 
     280            CALL lim_itd_me_ridgeprep 
    311281            IF( niter  >  nitermax ) THEN 
    312282               WRITE(numout,*) ' ALERTE : non-converging ridging scheme ' 
    313283               WRITE(numout,*) ' niter, iterate_ridging ', niter, iterate_ridging 
    314284            ENDIF 
    315             CALL lim_itd_me_ridgeprep 
    316285         ENDIF 
    317286 
    318287      END DO !! on the do while over iter 
    319  
    320       !-----------------------------------------------------------------------------! 
    321       ! 4) Ridging diagnostics 
    322       !-----------------------------------------------------------------------------! 
    323       ! Convert ridging rate diagnostics to correct units. 
    324       ! Update fresh water and heat fluxes due to snow melt. 
    325       DO jj = 1, jpj 
    326          DO ji = 1, jpi 
    327  
    328             dardg1dt(ji,jj) = dardg1dt(ji,jj) * r1_rdtice 
    329             dardg2dt(ji,jj) = dardg2dt(ji,jj) * r1_rdtice 
    330             dvirdgdt(ji,jj) = dvirdgdt(ji,jj) * r1_rdtice 
    331             opening (ji,jj) = opening (ji,jj) * r1_rdtice 
    332  
    333             !-----------------------------------------------------------------------------! 
    334             ! 5) Heat, salt and freshwater fluxes 
    335             !-----------------------------------------------------------------------------! 
    336             wfx_snw(ji,jj) = wfx_snw(ji,jj) + msnow_mlt(ji,jj) * r1_rdtice     ! fresh water source for ocean 
    337             hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + esnow_mlt(ji,jj) * r1_rdtice     ! heat sink for ocean (<0, W.m-2) 
    338  
    339          END DO 
    340       END DO 
    341  
    342       ! Check if there is a ridging error 
    343       IF( lwp ) THEN 
    344          DO jj = 1, jpj 
    345             DO ji = 1, jpi 
    346                IF( ABS( asum(ji,jj) - kamax)  >  epsi10 ) THEN   ! there is a bug 
    347                   WRITE(numout,*) ' ' 
    348                   WRITE(numout,*) ' ALERTE : Ridging error: total area = ', asum(ji,jj) 
    349                   WRITE(numout,*) ' limitd_me ' 
    350                   WRITE(numout,*) ' POINT : ', ji, jj 
    351                   WRITE(numout,*) ' jpl, a_i, athorn ' 
    352                   WRITE(numout,*) 0, ato_i(ji,jj), athorn(ji,jj,0) 
    353                   DO jl = 1, jpl 
    354                      WRITE(numout,*) jl, a_i(ji,jj,jl), athorn(ji,jj,jl) 
    355                   END DO 
    356                ENDIF 
    357             END DO 
    358          END DO 
    359       END IF 
    360  
    361       ! Conservation check 
    362       IF ( con_i ) THEN 
    363          CALL lim_column_sum (jpl,   v_i, vt_i_final) 
    364          fieldid = ' v_i : limitd_me ' 
    365          CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid)  
    366       ENDIF 
    367288 
    368289      CALL lim_var_agg( 1 )  
    … …  
    410331      ENDIF  ! ln_limdyn=.true. 
    411332      ! 
    412       CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross, msnow_mlt, esnow_mlt, vt_i_init, vt_i_final ) 
     333      CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross ) 
    413334      ! 
    414335      IF( nn_timing == 1 )  CALL timing_stop('limitd_me') 
    415336   END SUBROUTINE lim_itd_me 
    416337 
     338   SUBROUTINE lim_itd_me_ridgeprep 
     339      !!---------------------------------------------------------------------! 
     340      !!                ***  ROUTINE lim_itd_me_ridgeprep *** 
     341      !! 
     342      !! ** Purpose :   preparation for ridging and strength calculations 
     343      !! 
     344      !! ** Method  :   Compute the thickness distribution of the ice and open water  
     345      !!              participating in ridging and of the resulting ridges. 
     346      !!---------------------------------------------------------------------! 
     347      INTEGER ::   ji,jj, jl    ! dummy loop indices 
     348      REAL(wp) ::   Gstari, astari, hrmean, zdummy   ! local scalar 
     349      REAL(wp), POINTER, DIMENSION(:,:,:) ::   Gsum      ! Gsum(n) = sum of areas in categories 0 to n 
     350      !------------------------------------------------------------------------------! 
     351 
     352      CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
     353 
     354      Gstari     = 1.0/rn_gstar     
     355      astari     = 1.0/rn_astar     
     356      aksum(:,:)    = 0.0 
     357      athorn(:,:,:) = 0.0 
     358      aridge(:,:,:) = 0.0 
     359      araft (:,:,:) = 0.0 
     360 
     361      ! Zero out categories with very small areas 
     362      CALL lim_var_zapsmall 
     363 
     364      ! Ice thickness needed for rafting 
     365      DO jl = 1, jpl 
     366         DO jj = 1, jpj 
     367            DO ji = 1, jpi 
     368               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) 
     369               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     370            END DO 
     371         END DO 
     372      END DO 
     373 
     374      !------------------------------------------------------------------------------! 
     375      ! 1) Participation function  
     376      !------------------------------------------------------------------------------! 
     377 
     378      ! Compute total area of ice plus open water. 
     379      ! This is in general not equal to one because of divergence during transport 
     380      asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 
     381 
     382      ! Compute cumulative thickness distribution function 
     383      ! Compute the cumulative thickness distribution function Gsum, 
     384      ! where Gsum(n) is the fractional area in categories 0 to n. 
     385      ! initial value (in h = 0) equals open water area 
     386      Gsum(:,:,-1) = 0._wp 
     387      Gsum(:,:,0 ) = ato_i(:,:) 
     388      ! for each value of h, you have to add ice concentration then 
     389      DO jl = 1, jpl 
     390         Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl) 
     391      END DO 
     392 
     393      ! Normalize the cumulative distribution to 1 
     394      DO jl = 0, jpl 
     395         Gsum(:,:,jl) = Gsum(:,:,jl) / asum(:,:) 
     396      END DO 
     397 
     398      ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn) 
     399      !-------------------------------------------------------------------------------------------------- 
     400      ! Compute the participation function athorn; this is analogous to 
     401      ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). 
     402      ! area lost from category n due to ridging/closing 
     403      ! athorn(n)   = total area lost due to ridging/closing 
     404      ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar).  
     405      ! 
     406      ! The expressions for athorn are found by integrating b(h)g(h) between 
     407      ! the category boundaries. 
     408      ! athorn is always >= 0 and SUM(athorn(0:jpl))=1 
     409      !----------------------------------------------------------------- 
     410 
     411      IF( nn_partfun == 0 ) THEN       !--- Linear formulation (Thorndike et al., 1975) 
     412         DO jl = 0, jpl     
     413            DO jj = 1, jpj  
     414               DO ji = 1, jpi 
     415                  IF    ( Gsum(ji,jj,jl)   < rn_gstar ) THEN 
     416                     athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * & 
     417                        &                        ( 2._wp - ( Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari ) 
     418                  ELSEIF( Gsum(ji,jj,jl-1) < rn_gstar ) THEN 
     419                     athorn(ji,jj,jl) = Gstari * ( rn_gstar       - Gsum(ji,jj,jl-1) ) *  & 
     420                        &                        ( 2._wp - ( Gsum(ji,jj,jl-1) + rn_gstar       ) * Gstari ) 
     421                  ELSE 
     422                     athorn(ji,jj,jl) = 0._wp 
     423                  ENDIF 
     424               END DO 
     425            END DO 
     426         END DO 
     427 
     428      ELSE                             !--- Exponential, more stable formulation (Lipscomb et al, 2007) 
     429         !                         
     430         zdummy = 1._wp / ( 1._wp - EXP(-astari) )        ! precompute exponential terms using Gsum as a work array 
     431         DO jl = -1, jpl 
     432            Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 
     433         END DO 
     434         DO jl = 0, jpl 
     435             athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 
     436         END DO 
     437         ! 
     438      ENDIF 
     439 
     440      IF( ln_rafting ) THEN      ! Ridging and rafting ice participation functions 
     441         ! 
     442         DO jl = 1, jpl 
     443            DO jj = 1, jpj  
     444               DO ji = 1, jpi 
     445                  zdummy           = TANH ( rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) 
     446                  aridge(ji,jj,jl) = ( 1._wp + zdummy ) * 0.5_wp * athorn(ji,jj,jl) 
     447                  araft (ji,jj,jl) = ( 1._wp - zdummy ) * 0.5_wp * athorn(ji,jj,jl) 
     448               END DO 
     449            END DO 
     450         END DO 
     451 
     452      ELSE 
     453         ! 
     454         DO jl = 1, jpl 
     455            aridge(:,:,jl) = athorn(:,:,jl) 
     456         END DO 
     457         ! 
     458      ENDIF 
     459 
     460      !----------------------------------------------------------------- 
     461      ! 2) Transfer function 
     462      !----------------------------------------------------------------- 
     463      ! Compute max and min ridged ice thickness for each ridging category. 
     464      ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 
     465      !  
     466      ! This parameterization is a modified version of Hibler (1980). 
     467      ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 
     468      !  and for very thick ridging ice must be >= krdgmin*hi 
     469      ! 
     470      ! The minimum ridging thickness, hrmin, is equal to 2*hi  
     471      !  (i.e., rafting) and for very thick ridging ice is 
     472      !  constrained by hrmin <= (hrmean + hi)/2. 
     473      !  
     474      ! The maximum ridging thickness, hrmax, is determined by 
     475      !  hrmean and hrmin. 
     476      ! 
     477      ! These modifications have the effect of reducing the ice strength 
     478      ! (relative to the Hibler formulation) when very thick ice is 
     479      ! ridging. 
     480      ! 
     481      ! aksum = net area removed/ total area removed 
     482      ! where total area removed = area of ice that ridges 
     483      !         net area removed = total area removed - area of new ridges 
     484      !----------------------------------------------------------------- 
     485 
     486      aksum(:,:) = athorn(:,:,0) 
     487      ! Transfer function 
     488      DO jl = 1, jpl !all categories have a specific transfer function 
     489         DO jj = 1, jpj 
     490            DO ji = 1, jpi 
     491                
     492               IF( athorn(ji,jj,jl) > 0._wp ) THEN 
     493                  hrmean          = MAX( SQRT( rn_hstar * ht_i(ji,jj,jl) ), ht_i(ji,jj,jl) * krdgmin ) 
     494                  hrmin(ji,jj,jl) = MIN( 2._wp * ht_i(ji,jj,jl), 0.5_wp * ( hrmean + ht_i(ji,jj,jl) ) ) 
     495                  hrmax(ji,jj,jl) = 2._wp * hrmean - hrmin(ji,jj,jl) 
     496                  hraft(ji,jj,jl) = ht_i(ji,jj,jl) / kraft 
     497                  krdg(ji,jj,jl)  = ht_i(ji,jj,jl) / MAX( hrmean, epsi20 ) 
     498 
     499                  ! Normalization factor : aksum, ensures mass conservation 
     500                  aksum(ji,jj) = aksum(ji,jj) + aridge(ji,jj,jl) * ( 1._wp - krdg(ji,jj,jl) )    & 
     501                     &                        + araft (ji,jj,jl) * ( 1._wp - kraft          ) 
     502 
     503               ELSE 
     504                  hrmin(ji,jj,jl)  = 0._wp  
     505                  hrmax(ji,jj,jl)  = 0._wp  
     506                  hraft(ji,jj,jl)  = 0._wp  
     507                  krdg (ji,jj,jl)  = 1._wp 
     508               ENDIF 
     509 
     510            END DO 
     511         END DO 
     512      END DO 
     513      ! 
     514      CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
     515      ! 
     516   END SUBROUTINE lim_itd_me_ridgeprep 
     517 
     518 
     519   SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross ) 
     520      !!---------------------------------------------------------------------- 
     521      !!                ***  ROUTINE lim_itd_me_icestrength *** 
     522      !! 
     523      !! ** Purpose :   shift ridging ice among thickness categories of ice thickness 
     524      !! 
     525      !! ** Method  :   Remove area, volume, and energy from each ridging category 
     526      !!              and add to thicker ice categories. 
     527      !!---------------------------------------------------------------------- 
     528      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   opning         ! rate of opening due to divergence/shear 
     529      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   closing_gross  ! rate at which area removed, excluding area of new ridges 
     530      ! 
     531      CHARACTER (len=80) ::   fieldid   ! field identifier 
     532      ! 
     533      INTEGER ::   ji, jj, jl, jl1, jl2, jk   ! dummy loop indices 
     534      INTEGER ::   ij                ! horizontal index, combines i and j loops 
     535      INTEGER ::   icells            ! number of cells with a_i > puny 
     536      REAL(wp) ::   hL, hR, farea    ! left and right limits of integration 
     537 
     538      INTEGER , POINTER, DIMENSION(:) ::   indxi, indxj   ! compressed indices 
     539      REAL(wp), POINTER, DIMENSION(:) ::   zswitch, fvol   ! new ridge volume going to n2 
     540 
     541      REAL(wp), POINTER, DIMENSION(:) ::   afrac            ! fraction of category area ridged  
     542      REAL(wp), POINTER, DIMENSION(:) ::   ardg1 , ardg2    ! area of ice ridged & new ridges 
     543      REAL(wp), POINTER, DIMENSION(:) ::   vsrdg , esrdg    ! snow volume & energy of ridging ice 
     544      REAL(wp), POINTER, DIMENSION(:) ::   dhr   , dhr2     ! hrmax - hrmin  &  hrmax^2 - hrmin^2 
     545 
     546      REAL(wp), POINTER, DIMENSION(:) ::   vrdg1   ! volume of ice ridged 
     547      REAL(wp), POINTER, DIMENSION(:) ::   vrdg2   ! volume of new ridges 
     548      REAL(wp), POINTER, DIMENSION(:) ::   vsw     ! volume of seawater trapped into ridges 
     549      REAL(wp), POINTER, DIMENSION(:) ::   srdg1   ! sal*volume of ice ridged 
     550      REAL(wp), POINTER, DIMENSION(:) ::   srdg2   ! sal*volume of new ridges 
     551      REAL(wp), POINTER, DIMENSION(:) ::   smsw    ! sal*volume of water trapped into ridges 
     552      REAL(wp), POINTER, DIMENSION(:) ::   oirdg1, oirdg2   ! ice age of ice ridged 
     553 
     554      REAL(wp), POINTER, DIMENSION(:) ::   afrft            ! fraction of category area rafted 
     555      REAL(wp), POINTER, DIMENSION(:) ::   arft1 , arft2    ! area of ice rafted and new rafted zone 
     556      REAL(wp), POINTER, DIMENSION(:) ::   virft , vsrft    ! ice & snow volume of rafting ice 
     557      REAL(wp), POINTER, DIMENSION(:) ::   esrft , smrft    ! snow energy & salinity of rafting ice 
     558      REAL(wp), POINTER, DIMENSION(:) ::   oirft1, oirft2   ! ice age of ice rafted 
     559 
     560      REAL(wp), POINTER, DIMENSION(:,:) ::   eirft      ! ice energy of rafting ice 
     561      REAL(wp), POINTER, DIMENSION(:,:) ::   erdg1      ! enth*volume of ice ridged 
     562      REAL(wp), POINTER, DIMENSION(:,:) ::   erdg2      ! enth*volume of new ridges 
     563      REAL(wp), POINTER, DIMENSION(:,:) ::   ersw       ! enth of water trapped into ridges 
     564      !!---------------------------------------------------------------------- 
     565 
     566      CALL wrk_alloc( jpij,        indxi, indxj ) 
     567      CALL wrk_alloc( jpij,        zswitch, fvol ) 
     568      CALL wrk_alloc( jpij,        afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
     569      CALL wrk_alloc( jpij,        vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
     570      CALL wrk_alloc( jpij,        afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
     571      CALL wrk_alloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 
     572 
     573      !------------------------------------------------------------------------------- 
     574      ! 1) Compute change in open water area due to closing and opening. 
     575      !------------------------------------------------------------------------------- 
     576      DO jj = 1, jpj 
     577         DO ji = 1, jpi 
     578            ato_i(ji,jj) = MAX( 0._wp, ato_i(ji,jj) +  & 
     579               &                     ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice ) 
     580         END DO 
     581      END DO 
     582 
     583      !----------------------------------------------------------------- 
     584      ! 3) Pump everything from ice which is being ridged / rafted 
     585      !----------------------------------------------------------------- 
     586      ! Compute the area, volume, and energy of ice ridging in each 
     587      ! category, along with the area of the resulting ridge. 
     588 
     589      DO jl1 = 1, jpl !jl1 describes the ridging category 
     590 
     591         !------------------------------------------------ 
     592         ! 3.1) Identify grid cells with nonzero ridging 
     593         !------------------------------------------------ 
     594         icells = 0 
     595         DO jj = 1, jpj 
     596            DO ji = 1, jpi 
     597               IF( athorn(ji,jj,jl1) > 0._wp .AND. closing_gross(ji,jj) > 0._wp ) THEN 
     598                  icells = icells + 1 
     599                  indxi(icells) = ji 
     600                  indxj(icells) = jj 
     601               ENDIF 
     602            END DO 
     603         END DO 
     604 
     605         DO ij = 1, icells 
     606            ji = indxi(ij) ; jj = indxj(ij) 
     607 
     608            !-------------------------------------------------------------------- 
     609            ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2) 
     610            !-------------------------------------------------------------------- 
     611            ardg1(ij) = aridge(ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 
     612            arft1(ij) = araft (ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 
     613 
     614            !--------------------------------------------------------------- 
     615            ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1  
     616            !--------------------------------------------------------------- 
     617            afrac(ij) = ardg1(ij) / a_i(ji,jj,jl1) !ridging 
     618            afrft(ij) = arft1(ij) / a_i(ji,jj,jl1) !rafting 
     619            ardg2(ij) = ardg1(ij) * krdg(ji,jj,jl1) 
     620            arft2(ij) = arft1(ij) * kraft 
     621 
     622            !-------------------------------------------------------------------------- 
     623            ! 3.4) Subtract area, volume, and energy from ridging  
     624            !     / rafting category n1. 
     625            !-------------------------------------------------------------------------- 
     626            vrdg1(ij) = v_i(ji,jj,jl1) * afrac(ij) 
     627            vrdg2(ij) = vrdg1(ij) * ( 1. + rn_por_rdg ) 
     628            vsw  (ij) = vrdg1(ij) * rn_por_rdg 
     629 
     630            vsrdg (ij) = v_s  (ji,jj,  jl1) * afrac(ij) 
     631            esrdg (ij) = e_s  (ji,jj,1,jl1) * afrac(ij) 
     632            srdg1 (ij) = smv_i(ji,jj,  jl1) * afrac(ij) 
     633            oirdg1(ij) = oa_i (ji,jj,  jl1) * afrac(ij) 
     634            oirdg2(ij) = oa_i (ji,jj,  jl1) * afrac(ij) * krdg(ji,jj,jl1)  
     635 
     636            ! rafting volumes, heat contents ... 
     637            virft (ij) = v_i  (ji,jj,  jl1) * afrft(ij) 
     638            vsrft (ij) = v_s  (ji,jj,  jl1) * afrft(ij) 
     639            esrft (ij) = e_s  (ji,jj,1,jl1) * afrft(ij) 
     640            smrft (ij) = smv_i(ji,jj,  jl1) * afrft(ij)  
     641            oirft1(ij) = oa_i (ji,jj,  jl1) * afrft(ij)  
     642            oirft2(ij) = oa_i (ji,jj,  jl1) * afrft(ij) * kraft  
     643 
     644            !----------------------------------------------------------------- 
     645            ! 3.5) Compute properties of new ridges 
     646            !----------------------------------------------------------------- 
     647            smsw(ij)  = vsw(ij) * sss_m(ji,jj)                   ! salt content of seawater frozen in voids 
     648            srdg2(ij) = srdg1(ij) + smsw(ij)                     ! salt content of new ridge 
     649             
     650            sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ij) * rhoic * r1_rdtice 
     651            wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ij) * rhoic * r1_rdtice   ! increase in ice volume due to seawater frozen in voids 
     652             
     653             ! virtual salt flux to keep salinity constant 
     654            IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     655               srdg2(ij)      = srdg2(ij) - vsw(ij) * ( sss_m(ji,jj) - sm_i(ji,jj,jl1) )           ! ridge salinity = sm_i 
     656               sfx_bri(ji,jj) = sfx_bri(ji,jj) + sss_m(ji,jj)    * vsw(ij) * rhoic * r1_rdtice  &  ! put back sss_m into the ocean 
     657                  &                            - sm_i(ji,jj,jl1) * vsw(ij) * rhoic * r1_rdtice     ! and get  sm_i  from the ocean  
     658            ENDIF 
     659 
     660            !------------------------------------------             
     661            ! 3.7 Put the snow somewhere in the ocean 
     662            !------------------------------------------             
     663            !  Place part of the snow lost by ridging into the ocean.  
     664            !  Note that esrdg > 0; the ocean must cool to melt snow. 
     665            !  If the ocean temp = Tf already, new ice must grow. 
     666            !  During the next time step, thermo_rates will determine whether 
     667            !  the ocean cools or new ice grows. 
     668            wfx_snw(ji,jj) = wfx_snw(ji,jj) + ( rhosn * vsrdg(ij) * ( 1._wp - rn_fsnowrdg )   &  
     669               &                              + rhosn * vsrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice  ! fresh water source for ocean 
     670 
     671            hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ( - esrdg(ij) * ( 1._wp - rn_fsnowrdg )         &  
     672               &                                - esrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice        ! heat sink for ocean (<0, W.m-2) 
     673                
     674            !----------------------------------------------------------------- 
     675            ! 3.8 Compute quantities used to apportion ice among categories 
     676            ! in the n2 loop below 
     677            !----------------------------------------------------------------- 
     678            dhr (ij) = 1._wp / ( hrmax(ji,jj,jl1)                    - hrmin(ji,jj,jl1)                    ) 
     679            dhr2(ij) = 1._wp / ( hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) ) 
     680 
     681 
     682            ! update jl1 (removing ridged/rafted area) 
     683            a_i  (ji,jj,  jl1) = a_i  (ji,jj,  jl1) - ardg1 (ij) - arft1 (ij) 
     684            v_i  (ji,jj,  jl1) = v_i  (ji,jj,  jl1) - vrdg1 (ij) - virft (ij) 
     685            v_s  (ji,jj,  jl1) = v_s  (ji,jj,  jl1) - vsrdg (ij) - vsrft (ij) 
     686            e_s  (ji,jj,1,jl1) = e_s  (ji,jj,1,jl1) - esrdg (ij) - esrft (ij) 
     687            smv_i(ji,jj,  jl1) = smv_i(ji,jj,  jl1) - srdg1 (ij) - smrft (ij) 
     688            oa_i (ji,jj,  jl1) = oa_i (ji,jj,  jl1) - oirdg1(ij) - oirft1(ij) 
     689 
     690         END DO 
     691 
     692         !-------------------------------------------------------------------- 
     693         ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and 
     694         !      compute ridged ice enthalpy  
     695         !-------------------------------------------------------------------- 
     696         DO jk = 1, nlay_i 
     697            DO ij = 1, icells 
     698               ji = indxi(ij) ; jj = indxj(ij) 
     699               ! heat content of ridged ice 
     700               erdg1(ij,jk) = e_i(ji,jj,jk,jl1) * afrac(ij)  
     701               eirft(ij,jk) = e_i(ji,jj,jk,jl1) * afrft(ij)                
     702                
     703               ! enthalpy of the trapped seawater (J/m2, >0) 
     704               ! clem: if sst>0, then ersw <0 (is that possible?) 
     705               ersw(ij,jk)  = - rhoic * vsw(ij) * rcp * sst_m(ji,jj) * r1_nlay_i 
     706 
     707               ! heat flux to the ocean 
     708               hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ij,jk) * r1_rdtice  ! > 0 [W.m-2] ocean->ice flux  
     709 
     710               ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 
     711               erdg2(ij,jk) = erdg1(ij,jk) + ersw(ij,jk) 
     712 
     713               ! update jl1 
     714               e_i  (ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) - erdg1(ij,jk) - eirft(ij,jk) 
     715 
     716            END DO 
     717         END DO 
     718 
     719         !------------------------------------------------------------------------------- 
     720         ! 4) Add area, volume, and energy of new ridge to each category jl2 
     721         !------------------------------------------------------------------------------- 
     722         DO jl2  = 1, jpl  
     723            ! over categories to which ridged/rafted ice is transferred 
     724            DO ij = 1, icells 
     725               ji = indxi(ij) ; jj = indxj(ij) 
     726 
     727               ! Compute the fraction of ridged ice area and volume going to thickness category jl2. 
     728               IF( hrmin(ji,jj,jl1) <= hi_max(jl2) .AND. hrmax(ji,jj,jl1) > hi_max(jl2-1) ) THEN 
     729                  hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) ) 
     730                  hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2)   ) 
     731                  farea    = ( hR      - hL      ) * dhr(ij)  
     732                  fvol(ij) = ( hR * hR - hL * hL ) * dhr2(ij) 
     733               ELSE 
     734                  farea    = 0._wp  
     735                  fvol(ij) = 0._wp                   
     736               ENDIF 
     737 
     738               ! Compute the fraction of rafted ice area and volume going to thickness category jl2 
     739               IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) >  hi_max(jl2-1) ) THEN 
     740                  zswitch(ij) = 1._wp 
     741               ELSE 
     742                  zswitch(ij) = 0._wp                   
     743               ENDIF 
     744 
     745               a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + ( ardg2 (ij) * farea    + arft2 (ij) * zswitch(ij) ) 
     746               oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + ( oirdg2(ij) * farea    + oirft2(ij) * zswitch(ij) ) 
     747               v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + ( vrdg2 (ij) * fvol(ij) + virft (ij) * zswitch(ij) ) 
     748               smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + ( srdg2 (ij) * fvol(ij) + smrft (ij) * zswitch(ij) ) 
     749               v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + ( vsrdg (ij) * rn_fsnowrdg * fvol(ij)  +  & 
     750                  &                                        vsrft (ij) * rn_fsnowrft * zswitch(ij) ) 
     751               e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + ( esrdg (ij) * rn_fsnowrdg * fvol(ij)  +  & 
     752                  &                                        esrft (ij) * rn_fsnowrft * zswitch(ij) ) 
     753 
     754            END DO 
     755 
     756            ! Transfer ice energy to category jl2 by ridging 
     757            DO jk = 1, nlay_i 
     758               DO ij = 1, icells 
     759                  ji = indxi(ij) ; jj = indxj(ij) 
     760                  e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + erdg2(ij,jk) * fvol(ij) + eirft(ij,jk) * zswitch(ij)                   
     761               END DO 
     762            END DO 
     763            ! 
     764         END DO ! jl2 
     765          
     766      END DO ! jl1 (deforming categories) 
     767 
     768      ! 
     769      CALL wrk_dealloc( jpij,        indxi, indxj ) 
     770      CALL wrk_dealloc( jpij,        zswitch, fvol ) 
     771      CALL wrk_dealloc( jpij,        afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
     772      CALL wrk_dealloc( jpij,        vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
     773      CALL wrk_dealloc( jpij,        afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
     774      CALL wrk_dealloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 
     775      ! 
     776   END SUBROUTINE lim_itd_me_ridgeshift 
    417777 
    418778   SUBROUTINE lim_itd_me_icestrength( kstrngth ) 
    … …  
    434794      INTEGER             ::   ksmooth     ! smoothing the resistance to deformation 
    435795      INTEGER             ::   numts_rm    ! number of time steps for the P smoothing 
    436       REAL(wp)            ::   zhi, zp, z1_3  ! local scalars 
     796      REAL(wp)            ::   zp, z1_3    ! local scalars 
    437797      REAL(wp), POINTER, DIMENSION(:,:) ::   zworka   ! temporary array used here 
    438798      !!---------------------------------------------------------------------- 
    … …  
    459819               DO ji = 1, jpi 
    460820                  ! 
    461                   IF( a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0._wp ) THEN 
    462                      zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
     821                  IF( athorn(ji,jj,jl) > 0._wp ) THEN 
    463822                     !---------------------------- 
    464823                     ! PE loss from deforming ice 
    465824                     !---------------------------- 
    466                      strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * zhi * zhi 
     825                     strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 
    467826 
    468827                     !-------------------------- 
    469828                     ! PE gain from rafting ice 
    470829                     !-------------------------- 
    471                      strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * zhi * zhi 
     830                     strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 
    472831 
    473832                     !---------------------------- 
    474833                     ! PE gain from ridging ice 
    475834                     !---------------------------- 
    476                      strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) / krdg(ji,jj,jl)     & 
    477                         * z1_3 * ( hrmax(ji,jj,jl)**2 + hrmin(ji,jj,jl)**2 +  hrmax(ji,jj,jl) * hrmin(ji,jj,jl) )   
     835                     strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) * krdg(ji,jj,jl) * z1_3 *  & 
     836                        &                              ( hrmax(ji,jj,jl) * hrmax(ji,jj,jl) +         & 
     837                        &                                hrmin(ji,jj,jl) * hrmin(ji,jj,jl) +         & 
     838                        &                                hrmax(ji,jj,jl) * hrmin(ji,jj,jl) )   
    478839                        !!(a**3-b**3)/(a-b) = a*a+ab+b*b                       
    479840                  ENDIF 
    … …  
    497858         ! 
    498859      ENDIF                     ! kstrngth 
    499  
    500860      ! 
    501861      !------------------------------------------------------------------------------! 
    … …  
    503863      !------------------------------------------------------------------------------! 
    504864      ! CAN BE REMOVED 
    505       ! 
    506865      IF( ln_icestr_bvf ) THEN 
    507  
    508866         DO jj = 1, jpj 
    509867            DO ji = 1, jpi 
    510                strength(ji,jj) = strength(ji,jj) * exp(-5.88*SQRT(MAX(bv_i(ji,jj),0.0))) 
    511             END DO 
    512          END DO 
    513  
     868               strength(ji,jj) = strength(ji,jj) * exp(-5.88*SQRT(MAX(bvm_i(ji,jj),0.0))) 
     869            END DO 
     870         END DO 
    514871      ENDIF 
    515  
    516872      ! 
    517873      !------------------------------------------------------------------------------! 
    … …  
    558914      IF ( ksmooth == 2 ) THEN 
    559915 
    560  
    561916         CALL lbc_lnk( strength, 'T', 1. ) 
    562917 
    … …  
    565920               IF ( ( asum(ji,jj) - ato_i(ji,jj) ) > 0._wp) THEN  
    566921                  numts_rm = 1 ! number of time steps for the running mean 
    567                   IF ( strp1(ji,jj) > 0.0 ) numts_rm = numts_rm + 1 
    568                   IF ( strp2(ji,jj) > 0.0 ) numts_rm = numts_rm + 1 
     922                  IF ( strp1(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 
     923                  IF ( strp2(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 
    569924                  zp = ( strength(ji,jj) + strp1(ji,jj) + strp2(ji,jj) ) / numts_rm 
    570925                  strp2(ji,jj) = strp1(ji,jj) 
    … …  
    583938      ! 
    584939   END SUBROUTINE lim_itd_me_icestrength 
    585  
    586  
    587    SUBROUTINE lim_itd_me_ridgeprep 
    588       !!---------------------------------------------------------------------! 
    589       !!                ***  ROUTINE lim_itd_me_ridgeprep *** 
    590       !! 
    591       !! ** Purpose :   preparation for ridging and strength calculations 
    592       !! 
    593       !! ** Method  :   Compute the thickness distribution of the ice and open water  
    594       !!              participating in ridging and of the resulting ridges. 
    595       !!---------------------------------------------------------------------! 
    596       INTEGER ::   ji,jj, jl    ! dummy loop indices 
    597       REAL(wp) ::   Gstari, astari, zhi, hrmean, zdummy   ! local scalar 
    598       REAL(wp), POINTER, DIMENSION(:,:)   ::   zworka    ! temporary array used here 
    599       REAL(wp), POINTER, DIMENSION(:,:,:) ::   Gsum      ! Gsum(n) = sum of areas in categories 0 to n 
    600       !------------------------------------------------------------------------------! 
    601  
    602       CALL wrk_alloc( jpi,jpj, zworka ) 
    603       CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
    604  
    605       Gstari     = 1.0/rn_gstar     
    606       astari     = 1.0/rn_astar     
    607       aksum(:,:)    = 0.0 
    608       athorn(:,:,:) = 0.0 
    609       aridge(:,:,:) = 0.0 
    610       araft (:,:,:) = 0.0 
    611       hrmin(:,:,:)  = 0.0  
    612       hrmax(:,:,:)  = 0.0  
    613       hraft(:,:,:)  = 0.0  
    614       krdg (:,:,:)  = 1.0 
    615  
    616       !     ! Zero out categories with very small areas 
    617       CALL lim_var_zapsmall 
    618  
    619       !------------------------------------------------------------------------------! 
    620       ! 1) Participation function  
    621       !------------------------------------------------------------------------------! 
    622  
    623       ! Compute total area of ice plus open water. 
    624       ! This is in general not equal to one because of divergence during transport 
    625       asum(:,:) = ato_i(:,:) 
    626       DO jl = 1, jpl 
    627          asum(:,:) = asum(:,:) + a_i(:,:,jl) 
    628       END DO 
    629  
    630       ! Compute cumulative thickness distribution function 
    631       ! Compute the cumulative thickness distribution function Gsum, 
    632       ! where Gsum(n) is the fractional area in categories 0 to n. 
    633       ! initial value (in h = 0) equals open water area 
    634  
    635       Gsum(:,:,-1) = 0._wp 
    636       Gsum(:,:,0 ) = ato_i(:,:) 
    637  
    638       ! for each value of h, you have to add ice concentration then 
    639       DO jl = 1, jpl 
    640          Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl) 
    641       END DO 
    642  
    643       ! Normalize the cumulative distribution to 1 
    644       zworka(:,:) = 1._wp / Gsum(:,:,jpl) 
    645       DO jl = 0, jpl 
    646          Gsum(:,:,jl) = Gsum(:,:,jl) * zworka(:,:) 
    647       END DO 
    648  
    649       ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn) 
    650       !-------------------------------------------------------------------------------------------------- 
    651       ! Compute the participation function athorn; this is analogous to 
    652       ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). 
    653       ! area lost from category n due to ridging/closing 
    654       ! athorn(n)   = total area lost due to ridging/closing 
    655       ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar).  
    656       ! 
    657       ! The expressions for athorn are found by integrating b(h)g(h) between 
    658       ! the category boundaries. 
    659       !----------------------------------------------------------------- 
    660  
    661       IF( nn_partfun == 0 ) THEN       !--- Linear formulation (Thorndike et al., 1975) 
    662          DO jl = 0, jpl     
    663             DO jj = 1, jpj  
    664                DO ji = 1, jpi 
    665                   IF( Gsum(ji,jj,jl) < rn_gstar) THEN 
    666                      athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * & 
    667                         &                        ( 2.0 - (Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari ) 
    668                   ELSEIF (Gsum(ji,jj,jl-1) < rn_gstar) THEN 
    669                      athorn(ji,jj,jl) = Gstari * ( rn_gstar - Gsum(ji,jj,jl-1) ) *  & 
    670                         &                        ( 2.0 - ( Gsum(ji,jj,jl-1) + rn_gstar ) * Gstari ) 
    671                   ELSE 
    672                      athorn(ji,jj,jl) = 0.0 
    673                   ENDIF 
    674                END DO 
    675             END DO 
    676          END DO 
    677  
    678       ELSE                             !--- Exponential, more stable formulation (Lipscomb et al, 2007) 
    679          !                         
    680          zdummy = 1._wp / ( 1._wp - EXP(-astari) )        ! precompute exponential terms using Gsum as a work array 
    681          DO jl = -1, jpl 
    682             Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 
    683          END DO 
    684          DO jl = 0, jpl 
    685              athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 
    686          END DO 
    687          ! 
    688       ENDIF 
    689  
    690       IF( ln_rafting ) THEN      ! Ridging and rafting ice participation functions 
    691          ! 
    692          DO jl = 1, jpl 
    693             DO jj = 1, jpj  
    694                DO ji = 1, jpi 
    695                   IF ( athorn(ji,jj,jl) > 0._wp ) THEN 
    696 !!gm  TANH( -X ) = - TANH( X )  so can be computed only 1 time.... 
    697                      aridge(ji,jj,jl) = ( TANH (  rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl) 
    698                      araft (ji,jj,jl) = ( TANH ( -rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl) 
    699                      IF ( araft(ji,jj,jl) < epsi06 )   araft(ji,jj,jl)  = 0._wp 
    700                      aridge(ji,jj,jl) = MAX( athorn(ji,jj,jl) - araft(ji,jj,jl), 0.0 ) 
    701                   ENDIF 
    702                END DO 
    703             END DO 
    704          END DO 
    705  
    706       ELSE 
    707          ! 
    708          DO jl = 1, jpl 
    709             aridge(:,:,jl) = athorn(:,:,jl) 
    710          END DO 
    711          ! 
    712       ENDIF 
    713  
    714       IF( ln_rafting ) THEN 
    715  
    716          IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) > epsi10 .AND. lwp ) THEN 
    717             DO jl = 1, jpl 
    718                DO jj = 1, jpj 
    719                   DO ji = 1, jpi 
    720                      IF ( aridge(ji,jj,jl) + araft(ji,jj,jl) - athorn(ji,jj,jl) > epsi10 ) THEN 
    721                         WRITE(numout,*) ' ALERTE 96 : wrong participation function ... ' 
    722                         WRITE(numout,*) ' ji, jj, jl : ', ji, jj, jl 
    723                         WRITE(numout,*) ' lat, lon   : ', gphit(ji,jj), glamt(ji,jj) 
    724                         WRITE(numout,*) ' aridge     : ', aridge(ji,jj,1:jpl) 
    725                         WRITE(numout,*) ' araft      : ', araft(ji,jj,1:jpl) 
    726                         WRITE(numout,*) ' athorn     : ', athorn(ji,jj,1:jpl) 
    727                      ENDIF 
    728                   END DO 
    729                END DO 
    730             END DO 
    731          ENDIF 
    732  
    733       ENDIF 
    734  
    735       !----------------------------------------------------------------- 
    736       ! 2) Transfer function 
    737       !----------------------------------------------------------------- 
    738       ! Compute max and min ridged ice thickness for each ridging category. 
    739       ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 
    740       !  
    741       ! This parameterization is a modified version of Hibler (1980). 
    742       ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 
    743       !  and for very thick ridging ice must be >= krdgmin*hi 
    744       ! 
    745       ! The minimum ridging thickness, hrmin, is equal to 2*hi  
    746       !  (i.e., rafting) and for very thick ridging ice is 
    747       !  constrained by hrmin <= (hrmean + hi)/2. 
    748       !  
    749       ! The maximum ridging thickness, hrmax, is determined by 
    750       !  hrmean and hrmin. 
    751       ! 
    752       ! These modifications have the effect of reducing the ice strength 
    753       ! (relative to the Hibler formulation) when very thick ice is 
    754       ! ridging. 
    755       ! 
    756       ! aksum = net area removed/ total area removed 
    757       ! where total area removed = area of ice that ridges 
    758       !         net area removed = total area removed - area of new ridges 
    759       !----------------------------------------------------------------- 
    760  
    761       ! Transfer function 
    762       DO jl = 1, jpl !all categories have a specific transfer function 
    763          DO jj = 1, jpj 
    764             DO ji = 1, jpi 
    765  
    766                IF (a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0.0 ) THEN 
    767                   zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
    768                   hrmean          = MAX(SQRT(rn_hstar*zhi), zhi*krdgmin) 
    769                   hrmin(ji,jj,jl) = MIN(2.0*zhi, 0.5*(hrmean + zhi)) 
    770                   hrmax(ji,jj,jl) = 2.0*hrmean - hrmin(ji,jj,jl) 
    771                   hraft(ji,jj,jl) = kraft*zhi 
    772                   krdg(ji,jj,jl)  = hrmean / zhi 
    773                ELSE 
    774                   hraft(ji,jj,jl) = 0.0 
    775                   hrmin(ji,jj,jl) = 0.0  
    776                   hrmax(ji,jj,jl) = 0.0  
    777                   krdg (ji,jj,jl) = 1.0 
    778                ENDIF 
    779  
    780             END DO 
    781          END DO 
    782       END DO 
    783  
    784       ! Normalization factor : aksum, ensures mass conservation 
    785       aksum(:,:) = athorn(:,:,0) 
    786       DO jl = 1, jpl  
    787          aksum(:,:)    = aksum(:,:) + aridge(:,:,jl) * ( 1._wp - 1._wp / krdg(:,:,jl) )    & 
    788             &                       + araft (:,:,jl) * ( 1._wp - 1._wp / kraft        ) 
    789       END DO 
    790       ! 
    791       CALL wrk_dealloc( jpi,jpj, zworka ) 
    792       CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
    793       ! 
    794    END SUBROUTINE lim_itd_me_ridgeprep 
    795  
    796  
    797    SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt ) 
    798       !!---------------------------------------------------------------------- 
    799       !!                ***  ROUTINE lim_itd_me_icestrength *** 
    800       !! 
    801       !! ** Purpose :   shift ridging ice among thickness categories of ice thickness 
    802       !! 
    803       !! ** Method  :   Remove area, volume, and energy from each ridging category 
    804       !!              and add to thicker ice categories. 
    805       !!---------------------------------------------------------------------- 
    806       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   opning         ! rate of opening due to divergence/shear 
    807       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   closing_gross  ! rate at which area removed, excluding area of new ridges 
    808       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   msnow_mlt      ! mass of snow added to ocean (kg m-2) 
    809       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   esnow_mlt      ! energy needed to melt snow in ocean (J m-2) 
    810       ! 
    811       CHARACTER (len=80) ::   fieldid   ! field identifier 
    812       LOGICAL, PARAMETER ::   l_conservation_check = .true.  ! if true, check conservation (useful for debugging) 
    813       ! 
    814       INTEGER ::   ji, jj, jl, jl1, jl2, jk   ! dummy loop indices 
    815       INTEGER ::   ij                ! horizontal index, combines i and j loops 
    816       INTEGER ::   icells            ! number of cells with aicen > puny 
    817       REAL(wp) ::   hL, hR, farea, ztmelts    ! left and right limits of integration 
    818  
    819       INTEGER , POINTER, DIMENSION(:) ::   indxi, indxj   ! compressed indices 
    820  
    821       REAL(wp), POINTER, DIMENSION(:,:) ::   vice_init, vice_final   ! ice volume summed over categories 
    822       REAL(wp), POINTER, DIMENSION(:,:) ::   eice_init, eice_final   ! ice energy summed over layers 
    823  
    824       REAL(wp), POINTER, DIMENSION(:,:,:) ::   aicen_init, vicen_init   ! ice  area    & volume before ridging 
    825       REAL(wp), POINTER, DIMENSION(:,:,:) ::   vsnwn_init, esnwn_init   ! snow volume  & energy before ridging 
    826       REAL(wp), POINTER, DIMENSION(:,:,:) ::   smv_i_init, oa_i_init    ! ice salinity & age    before ridging 
    827  
    828       REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   eicen_init        ! ice energy before ridging 
    829  
    830       REAL(wp), POINTER, DIMENSION(:,:) ::   afrac , fvol     ! fraction of category area ridged & new ridge volume going to n2 
    831       REAL(wp), POINTER, DIMENSION(:,:) ::   ardg1 , ardg2    ! area of ice ridged & new ridges 
    832       REAL(wp), POINTER, DIMENSION(:,:) ::   vsrdg , esrdg    ! snow volume & energy of ridging ice 
    833       REAL(wp), POINTER, DIMENSION(:,:) ::   dhr   , dhr2     ! hrmax - hrmin  &  hrmax^2 - hrmin^2 
    834  
    835       REAL(wp), POINTER, DIMENSION(:,:) ::   vrdg1   ! volume of ice ridged 
    836       REAL(wp), POINTER, DIMENSION(:,:) ::   vrdg2   ! volume of new ridges 
    837       REAL(wp), POINTER, DIMENSION(:,:) ::   vsw     ! volume of seawater trapped into ridges 
    838       REAL(wp), POINTER, DIMENSION(:,:) ::   srdg1   ! sal*volume of ice ridged 
    839       REAL(wp), POINTER, DIMENSION(:,:) ::   srdg2   ! sal*volume of new ridges 
    840       REAL(wp), POINTER, DIMENSION(:,:) ::   smsw    ! sal*volume of water trapped into ridges 
    841       REAL(wp), POINTER, DIMENSION(:,:) ::   oirdg1, oirdg2   ! ice age of ice ridged 
    842  
    843       REAL(wp), POINTER, DIMENSION(:,:) ::   afrft            ! fraction of category area rafted 
    844       REAL(wp), POINTER, DIMENSION(:,:) ::   arft1 , arft2    ! area of ice rafted and new rafted zone 
    845       REAL(wp), POINTER, DIMENSION(:,:) ::   virft , vsrft    ! ice & snow volume of rafting ice 
    846       REAL(wp), POINTER, DIMENSION(:,:) ::   esrft , smrft    ! snow energy & salinity of rafting ice 
    847       REAL(wp), POINTER, DIMENSION(:,:) ::   oirft1, oirft2   ! ice age of ice rafted 
    848  
    849       REAL(wp), POINTER, DIMENSION(:,:,:) ::   eirft      ! ice energy of rafting ice 
    850       REAL(wp), POINTER, DIMENSION(:,:,:) ::   erdg1      ! enth*volume of ice ridged 
    851       REAL(wp), POINTER, DIMENSION(:,:,:) ::   erdg2      ! enth*volume of new ridges 
    852       REAL(wp), POINTER, DIMENSION(:,:,:) ::   ersw       ! enth of water trapped into ridges 
    853       !!---------------------------------------------------------------------- 
    854  
    855       CALL wrk_alloc( (jpi+1)*(jpj+1),       indxi, indxj ) 
    856       CALL wrk_alloc( jpi, jpj,              vice_init, vice_final, eice_init, eice_final ) 
    857       CALL wrk_alloc( jpi, jpj,              afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
    858       CALL wrk_alloc( jpi, jpj,              vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
    859       CALL wrk_alloc( jpi, jpj,              afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
    860       CALL wrk_alloc( jpi, jpj, jpl,         aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init ) 
    861       CALL wrk_alloc( jpi, jpj, nlay_i,      eirft, erdg1, erdg2, ersw ) 
    862       CALL wrk_alloc( jpi, jpj, nlay_i, jpl, eicen_init ) 
    863  
    864       ! Conservation check 
    865       eice_init(:,:) = 0._wp 
    866  
    867       IF( con_i ) THEN 
    868          CALL lim_column_sum        (jpl,    v_i,       vice_init ) 
    869          CALL lim_column_sum_energy (jpl, nlay_i,  e_i, eice_init ) 
    870          DO ji = mi0(iiceprt), mi1(iiceprt) 
    871             DO jj = mj0(jiceprt), mj1(jiceprt) 
    872                WRITE(numout,*) ' vice_init  : ', vice_init(ji,jj) 
    873                WRITE(numout,*) ' eice_init  : ', eice_init(ji,jj) 
    874             END DO 
    875          END DO 
    876       ENDIF 
    877  
    878       !------------------------------------------------------------------------------- 
    879       ! 1) Compute change in open water area due to closing and opening. 
    880       !------------------------------------------------------------------------------- 
    881       DO jj = 1, jpj 
    882          DO ji = 1, jpi 
    883             ato_i(ji,jj) = ato_i(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice        & 
    884                &                        + opning(ji,jj)                          * rdt_ice 
    885             IF    ( ato_i(ji,jj) < -epsi10 ) THEN    ! there is a bug 
    886                IF(lwp)   WRITE(numout,*) 'Ridging error: ato_i < 0 -- ato_i : ',ato_i(ji,jj) 
    887             ELSEIF( ato_i(ji,jj) < 0._wp   ) THEN    ! roundoff error 
    888                ato_i(ji,jj) = 0._wp 
    889             ENDIF 
    890          END DO 
    891       END DO 
    892  
    893       !----------------------------------------------------------------- 
    894       ! 2) Save initial state variables 
    895       !----------------------------------------------------------------- 
    896       aicen_init(:,:,:)   = a_i  (:,:,:) 
    897       vicen_init(:,:,:)   = v_i  (:,:,:) 
    898       vsnwn_init(:,:,:)   = v_s  (:,:,:) 
    899       smv_i_init(:,:,:)   = smv_i(:,:,:) 
    900       esnwn_init(:,:,:)   = e_s  (:,:,1,:) 
    901       eicen_init(:,:,:,:) = e_i  (:,:,:,:) 
    902       oa_i_init (:,:,:)   = oa_i (:,:,:) 
    903  
    904       ! 
    905       !----------------------------------------------------------------- 
    906       ! 3) Pump everything from ice which is being ridged / rafted 
    907       !----------------------------------------------------------------- 
    908       ! Compute the area, volume, and energy of ice ridging in each 
    909       ! category, along with the area of the resulting ridge. 
    910  
    911       DO jl1 = 1, jpl !jl1 describes the ridging category 
    912  
    913          !------------------------------------------------ 
    914          ! 3.1) Identify grid cells with nonzero ridging 
    915          !------------------------------------------------ 
    916  
    917          icells = 0 
    918          DO jj = 1, jpj 
    919             DO ji = 1, jpi 
    920                IF( aicen_init(ji,jj,jl1) > epsi10 .AND. athorn(ji,jj,jl1) > 0._wp  & 
    921                   &   .AND. closing_gross(ji,jj) > 0._wp ) THEN 
    922                   icells = icells + 1 
    923                   indxi(icells) = ji 
    924                   indxj(icells) = jj 
    925                ENDIF 
    926             END DO 
    927          END DO 
    928  
    929          DO ij = 1, icells 
    930             ji = indxi(ij) 
    931             jj = indxj(ij) 
    932  
    933             !-------------------------------------------------------------------- 
    934             ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2) 
    935             !-------------------------------------------------------------------- 
    936  
    937             ardg1(ji,jj) = aridge(ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice 
    938             arft1(ji,jj) = araft (ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice 
    939             ardg2(ji,jj) = ardg1(ji,jj) / krdg(ji,jj,jl1) 
    940             arft2(ji,jj) = arft1(ji,jj) / kraft 
    941  
    942             !--------------------------------------------------------------- 
    943             ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1  
    944             !--------------------------------------------------------------- 
    945  
    946             afrac(ji,jj) = ardg1(ji,jj) / aicen_init(ji,jj,jl1) !ridging 
    947             afrft(ji,jj) = arft1(ji,jj) / aicen_init(ji,jj,jl1) !rafting 
    948  
    949             IF( afrac(ji,jj) > kamax + epsi10 ) THEN  ! there is a bug 
    950                IF(lwp)   WRITE(numout,*) ' ardg > a_i -- ardg, aicen_init : ', ardg1(ji,jj), aicen_init(ji,jj,jl1) 
    951             ELSEIF( afrac(ji,jj) > kamax ) THEN       ! roundoff error 
    952                afrac(ji,jj) = kamax 
    953             ENDIF 
    954  
    955             IF( afrft(ji,jj) > kamax + epsi10 ) THEN ! there is a bug 
    956                IF(lwp)   WRITE(numout,*) ' arft > a_i -- arft, aicen_init : ', arft1(ji,jj), aicen_init(ji,jj,jl1)  
    957             ELSEIF( afrft(ji,jj) > kamax) THEN       ! roundoff error 
    958                afrft(ji,jj) = kamax 
    959             ENDIF 
    960  
    961             !-------------------------------------------------------------------------- 
    962             ! 3.4) Subtract area, volume, and energy from ridging  
    963             !     / rafting category n1. 
    964             !-------------------------------------------------------------------------- 
    965             vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj) 
    966             vrdg2(ji,jj) = vrdg1(ji,jj) * ( 1. + rn_por_rdg ) 
    967             vsw  (ji,jj) = vrdg1(ji,jj) * rn_por_rdg 
    968  
    969             vsrdg (ji,jj) = vsnwn_init(ji,jj,jl1) * afrac(ji,jj) 
    970             esrdg (ji,jj) = esnwn_init(ji,jj,jl1) * afrac(ji,jj) 
    971             srdg1 (ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) 
    972             oirdg1(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj) 
    973             oirdg2(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj) / krdg(ji,jj,jl1)  
    974  
    975             ! rafting volumes, heat contents ... 
    976             virft (ji,jj) = vicen_init(ji,jj,jl1) * afrft(ji,jj) 
    977             vsrft (ji,jj) = vsnwn_init(ji,jj,jl1) * afrft(ji,jj) 
    978             esrft (ji,jj) = esnwn_init(ji,jj,jl1) * afrft(ji,jj) 
    979             smrft (ji,jj) = smv_i_init(ji,jj,jl1) * afrft(ji,jj)  
    980             oirft1(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj)  
    981             oirft2(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj) / kraft  
    982  
    983             ! substract everything 
    984             a_i(ji,jj,jl1)   = a_i(ji,jj,jl1)   - ardg1 (ji,jj) - arft1 (ji,jj) 
    985             v_i(ji,jj,jl1)   = v_i(ji,jj,jl1)   - vrdg1 (ji,jj) - virft (ji,jj) 
    986             v_s(ji,jj,jl1)   = v_s(ji,jj,jl1)   - vsrdg (ji,jj) - vsrft (ji,jj) 
    987             e_s(ji,jj,1,jl1) = e_s(ji,jj,1,jl1) - esrdg (ji,jj) - esrft (ji,jj) 
    988             smv_i(ji,jj,jl1) = smv_i(ji,jj,jl1) - srdg1 (ji,jj) - smrft (ji,jj) 
    989             oa_i(ji,jj,jl1)  = oa_i(ji,jj,jl1)  - oirdg1(ji,jj) - oirft1(ji,jj) 
    990  
    991             !----------------------------------------------------------------- 
    992             ! 3.5) Compute properties of new ridges 
    993             !----------------------------------------------------------------- 
    994             !--------- 
    995             ! Salinity 
    996             !--------- 
    997             smsw(ji,jj)  = vsw(ji,jj) * sss_m(ji,jj)                      ! salt content of seawater frozen in voids !! MV HC2014 
    998             srdg2(ji,jj) = srdg1(ji,jj) + smsw(ji,jj)                     ! salt content of new ridge 
    999  
    1000             !srdg2(ji,jj) = MIN( rn_simax * vrdg2(ji,jj) , zsrdg2 )         ! impose a maximum salinity 
    1001              
    1002             sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ji,jj) * rhoic * r1_rdtice 
    1003             wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ji,jj) * rhoic * r1_rdtice   ! increase in ice volume du to seawater frozen in voids              
    1004  
    1005             !------------------------------------             
    1006             ! 3.6 Increment ridging diagnostics 
    1007             !------------------------------------             
    1008  
    1009             !        jl1 looping 1-jpl 
    1010             !           ij looping 1-icells 
    1011  
    1012             dardg1dt   (ji,jj) = dardg1dt(ji,jj) + ardg1(ji,jj) + arft1(ji,jj) 
    1013             dardg2dt   (ji,jj) = dardg2dt(ji,jj) + ardg2(ji,jj) + arft2(ji,jj) 
    1014             opening    (ji,jj) = opening (ji,jj) + opning(ji,jj) * rdt_ice 
    1015  
    1016             IF( con_i )   vice_init(ji,jj) = vice_init(ji,jj) + vrdg2(ji,jj) - vrdg1(ji,jj) 
    1017  
    1018             !------------------------------------------             
    1019             ! 3.7 Put the snow somewhere in the ocean 
    1020             !------------------------------------------             
    1021             !  Place part of the snow lost by ridging into the ocean.  
    1022             !  Note that esnow_mlt < 0; the ocean must cool to melt snow. 
    1023             !  If the ocean temp = Tf already, new ice must grow. 
    1024             !  During the next time step, thermo_rates will determine whether 
    1025             !  the ocean cools or new ice grows. 
    1026             !        jl1 looping 1-jpl 
    1027             !           ij looping 1-icells 
    1028  
    1029             msnow_mlt(ji,jj) = msnow_mlt(ji,jj) + rhosn*vsrdg(ji,jj)*(1.0-rn_fsnowrdg)   &   ! rafting included 
    1030                &                                + rhosn*vsrft(ji,jj)*(1.0-rn_fsnowrft) 
    1031  
    1032             ! in J/m2 (same as e_s) 
    1033             esnow_mlt(ji,jj) = esnow_mlt(ji,jj) - esrdg(ji,jj)*(1.0-rn_fsnowrdg)         &   !rafting included 
    1034                &                                - esrft(ji,jj)*(1.0-rn_fsnowrft)           
    1035  
    1036             !----------------------------------------------------------------- 
    1037             ! 3.8 Compute quantities used to apportion ice among categories 
    1038             ! in the n2 loop below 
    1039             !----------------------------------------------------------------- 
    1040  
    1041             !        jl1 looping 1-jpl 
    1042             !           ij looping 1-icells 
    1043  
    1044             dhr (ji,jj) = hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) 
    1045             dhr2(ji,jj) = hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) 
    1046  
    1047          END DO 
    1048  
    1049          !-------------------------------------------------------------------- 
    1050          ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and 
    1051          !      compute ridged ice enthalpy  
    1052          !-------------------------------------------------------------------- 
    1053          DO jk = 1, nlay_i 
    1054             DO ij = 1, icells 
    1055                ji = indxi(ij) 
    1056                jj = indxj(ij) 
    1057                ! heat content of ridged ice 
    1058                erdg1(ji,jj,jk)      = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj)  
    1059                eirft(ji,jj,jk)      = eicen_init(ji,jj,jk,jl1) * afrft(ji,jj) 
    1060                e_i  (ji,jj,jk,jl1)  = e_i(ji,jj,jk,jl1) - erdg1(ji,jj,jk) - eirft(ji,jj,jk) 
    1061                 
    1062                 
    1063                ! enthalpy of the trapped seawater (J/m2, >0) 
    1064                ! clem: if sst>0, then ersw <0 (is that possible?) 
    1065                ersw(ji,jj,jk)   = - rhoic * vsw(ji,jj) * rcp * sst_m(ji,jj) * r1_nlay_i 
    1066  
    1067                ! heat flux to the ocean 
    1068                hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ji,jj,jk) * r1_rdtice  ! > 0 [W.m-2] ocean->ice flux  
    1069  
    1070                ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 
    1071                erdg2(ji,jj,jk)  = erdg1(ji,jj,jk) + ersw(ji,jj,jk) 
    1072  
    1073             END DO 
    1074          END DO 
    1075  
    1076  
    1077          IF( con_i ) THEN 
    1078             DO jk = 1, nlay_i 
    1079                DO ij = 1, icells 
    1080                   ji = indxi(ij) 
    1081                   jj = indxj(ij) 
    1082                   eice_init(ji,jj) = eice_init(ji,jj) + erdg2(ji,jj,jk) - erdg1(ji,jj,jk) 
    1083                END DO 
    1084             END DO 
    1085          ENDIF 
    1086  
    1087          !------------------------------------------------------------------------------- 
    1088          ! 4) Add area, volume, and energy of new ridge to each category jl2 
    1089          !------------------------------------------------------------------------------- 
    1090          !        jl1 looping 1-jpl 
    1091          DO jl2  = 1, jpl  
    1092             ! over categories to which ridged ice is transferred 
    1093             DO ij = 1, icells 
    1094                ji = indxi(ij) 
    1095                jj = indxj(ij) 
    1096  
    1097                ! Compute the fraction of ridged ice area and volume going to  
    1098                ! thickness category jl2. 
    1099                ! Transfer area, volume, and energy accordingly. 
    1100  
    1101                IF( hrmin(ji,jj,jl1) >= hi_max(jl2) .OR. hrmax(ji,jj,jl1) <= hi_max(jl2-1) ) THEN 
    1102                   hL = 0._wp 
    1103                   hR = 0._wp 
    1104                ELSE 
    1105                   hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) ) 
    1106                   hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2)   ) 
    1107                ENDIF 
    1108  
    1109                ! fraction of ridged ice area and volume going to n2 
    1110                farea = ( hR - hL ) / dhr(ji,jj)  
    1111                fvol(ji,jj) = ( hR*hR - hL*hL ) / dhr2(ji,jj) 
    1112  
    1113                a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + ardg2 (ji,jj) * farea 
    1114                v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + vrdg2 (ji,jj) * fvol(ji,jj) 
    1115                v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + vsrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg 
    1116                e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + esrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg 
    1117                smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + srdg2 (ji,jj) * fvol(ji,jj) 
    1118                oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + oirdg2(ji,jj) * farea 
    1119  
    1120             END DO 
    1121  
    1122             ! Transfer ice energy to category jl2 by ridging 
    1123             DO jk = 1, nlay_i 
    1124                DO ij = 1, icells 
    1125                   ji = indxi(ij) 
    1126                   jj = indxj(ij) 
    1127                   e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + fvol(ji,jj) * erdg2(ji,jj,jk) 
    1128                END DO 
    1129             END DO 
    1130             ! 
    1131          END DO                 ! jl2 (new ridges)             
    1132  
    1133          DO jl2 = 1, jpl  
    1134  
    1135             DO ij = 1, icells 
    1136                ji = indxi(ij) 
    1137                jj = indxj(ij) 
    1138                ! Compute the fraction of rafted ice area and volume going to  
    1139                ! thickness category jl2, transfer area, volume, and energy accordingly. 
    1140                ! 
    1141                IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) >  hi_max(jl2-1) ) THEN 
    1142                   a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + arft2 (ji,jj) 
    1143                   v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + virft (ji,jj) 
    1144                   v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + vsrft (ji,jj) * rn_fsnowrft 
    1145                   e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + esrft (ji,jj) * rn_fsnowrft 
    1146                   smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + smrft (ji,jj)     
    1147                   oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + oirft2(ji,jj) 
    1148                ENDIF 
    1149                ! 
    1150             END DO 
    1151  
    1152             ! Transfer rafted ice energy to category jl2  
    1153             DO jk = 1, nlay_i 
    1154                DO ij = 1, icells 
    1155                   ji = indxi(ij) 
    1156                   jj = indxj(ij) 
    1157                   IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1)  ) THEN 
    1158                      e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + eirft(ji,jj,jk) 
    1159                   ENDIF 
    1160                END DO 
    1161             END DO 
    1162  
    1163          END DO 
    1164  
    1165       END DO ! jl1 (deforming categories) 
    1166  
    1167       ! Conservation check 
    1168       IF ( con_i ) THEN 
    1169          CALL lim_column_sum (jpl,   v_i, vice_final) 
    1170          fieldid = ' v_i : limitd_me ' 
    1171          CALL lim_cons_check (vice_init, vice_final, 1.0e-6, fieldid)  
    1172  
    1173          CALL lim_column_sum_energy (jpl, nlay_i,  e_i, eice_final ) 
    1174          fieldid = ' e_i : limitd_me ' 
    1175          CALL lim_cons_check (eice_init, eice_final, 1.0e-2, fieldid)  
    1176  
    1177          DO ji = mi0(iiceprt), mi1(iiceprt) 
    1178             DO jj = mj0(jiceprt), mj1(jiceprt) 
    1179                WRITE(numout,*) ' vice_init  : ', vice_init (ji,jj) 
    1180                WRITE(numout,*) ' vice_final : ', vice_final(ji,jj) 
    1181                WRITE(numout,*) ' eice_init  : ', eice_init (ji,jj) 
    1182                WRITE(numout,*) ' eice_final : ', eice_final(ji,jj) 
    1183             END DO 
    1184          END DO 
    1185       ENDIF 
    1186       ! 
    1187       CALL wrk_dealloc( (jpi+1)*(jpj+1),        indxi, indxj ) 
    1188       CALL wrk_dealloc( jpi, jpj,               vice_init, vice_final, eice_init, eice_final ) 
    1189       CALL wrk_dealloc( jpi, jpj,               afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
    1190       CALL wrk_dealloc( jpi, jpj,               vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
    1191       CALL wrk_dealloc( jpi, jpj,               afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
    1192       CALL wrk_dealloc( jpi, jpj, jpl,          aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init ) 
    1193       CALL wrk_dealloc( jpi, jpj, nlay_i,       eirft, erdg1, erdg2, ersw ) 
    1194       CALL wrk_dealloc( jpi, jpj, nlay_i, jpl,  eicen_init ) 
    1195       ! 
    1196    END SUBROUTINE lim_itd_me_ridgeshift 
    1197940 
    1198941   SUBROUTINE lim_itd_me_init 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90

    r5602 r7256  
    1010   !!            3.4  !  2011-01  (A. Porter)  dynamical allocation  
    1111   !!            3.5  !  2012-08  (R. Benshila)  AGRIF  
     12   !!            3.6  !  2016-06  (C. Rousset) Rewriting (conserves energy) 
    1213   !!---------------------------------------------------------------------- 
    1314#if defined key_lim3 || (  defined key_lim2 && ! defined key_lim2_vp ) 
    … …  
    9596      !!                 coriolis terms of the momentum equation 
    9697      !!              3) Solve the momentum equation (iterative procedure) 
    97       !!              4) Prevent high velocities if the ice is thin 
    98       !!              5) Recompute invariants of the strain rate tensor 
     98      !!              4) Recompute invariants of the strain rate tensor 
    9999      !!                 which are inputs of the ITD, store stress 
    100100      !!                 for the next time step 
    101       !!              6) Control prints of residual (convergence) 
     101      !!              5) Control prints of residual (convergence) 
    102102      !!                 and charge ellipse. 
    103103      !!                 The user should make sure that the parameters 
    … …  
    106106      !!                 e.g. in the Canadian Archipelago 
    107107      !! 
     108      !! ** Notes   : Boundary condition for ice is chosen no-slip  
     109      !!              but can be adjusted with param rn_shlat 
     110      !! 
    108111      !! References : Hunke and Dukowicz, JPO97 
    109112      !!              Bouillon et al., Ocean Modelling 2009 
    … …  
    115118      INTEGER ::   jter     ! local integers 
    116119      CHARACTER (len=50) ::   charout 
    117       REAL(wp) ::   zt11, zt12, zt21, zt22, ztagnx, ztagny, delta                         ! 
    118       REAL(wp) ::   za, zstms          ! local scalars 
    119       REAL(wp) ::   zc1, zc2, zc3      ! ice mass 
    120  
    121       REAL(wp) ::   dtevp , z1_dtevp              ! time step for subcycling 
    122       REAL(wp) ::   dtotel, z1_dtotel, ecc2, ecci ! square of yield ellipse eccenticity 
    123       REAL(wp) ::   z0, zr, zcca, zccb            ! temporary scalars 
    124       REAL(wp) ::   zu_ice2, zv_ice1              ! 
    125       REAL(wp) ::   zddc, zdtc                    ! delta on corners and on centre 
    126       REAL(wp) ::   zdst                          ! shear at the center of the grid point 
    127       REAL(wp) ::   zdsshx, zdsshy                ! term for the gradient of ocean surface 
    128       REAL(wp) ::   sigma1, sigma2                ! internal ice stress 
    129  
    130       REAL(wp) ::   zresm         ! Maximal error on ice velocity 
    131       REAL(wp) ::   zintb, zintn  ! dummy argument 
    132  
    133       REAL(wp), POINTER, DIMENSION(:,:) ::   zpresh           ! temporary array for ice strength 
    134       REAL(wp), POINTER, DIMENSION(:,:) ::   zpreshc          ! Ice strength on grid cell corners (zpreshc) 
    135       REAL(wp), POINTER, DIMENSION(:,:) ::   zfrld1, zfrld2   ! lead fraction on U/V points 
    136       REAL(wp), POINTER, DIMENSION(:,:) ::   zmass1, zmass2   ! ice/snow mass on U/V points 
    137       REAL(wp), POINTER, DIMENSION(:,:) ::   zcorl1, zcorl2   ! coriolis parameter on U/V points 
    138       REAL(wp), POINTER, DIMENSION(:,:) ::   za1ct , za2ct    ! temporary arrays 
    139       REAL(wp), POINTER, DIMENSION(:,:) ::   v_oce1           ! ocean u/v component on U points                            
    140       REAL(wp), POINTER, DIMENSION(:,:) ::   u_oce2           ! ocean u/v component on V points 
    141       REAL(wp), POINTER, DIMENSION(:,:) ::   u_ice2, v_ice1   ! ice u/v component on V/U point 
    142       REAL(wp), POINTER, DIMENSION(:,:) ::   zf1   , zf2      ! arrays for internal stresses 
    143       REAL(wp), POINTER, DIMENSION(:,:) ::   zmask            ! mask ocean grid points 
     120 
     121      REAL(wp) ::   zdtevp, z1_dtevp                                         ! time step for subcycling 
     122      REAL(wp) ::   ecc2, z1_ecc2                                            ! square of yield ellipse eccenticity 
     123      REAL(wp) ::   zbeta, zalph1, z1_alph1, zalph2, z1_alph2                ! alpha and beta from Bouillon 2009 and 2013 
     124      REAL(wp) ::   zm1, zm2, zm3, zmassU, zmassV                            ! ice/snow mass 
     125      REAL(wp) ::   zdelta, zp_delf, zds2, zdt, zdt2, zdiv, zdiv2            ! temporary scalars 
     126      REAL(wp) ::   zTauO, zTauE, zCor                                       ! temporary scalars 
     127 
     128      REAL(wp) ::   zsig1, zsig2                                             ! internal ice stress 
     129      REAL(wp) ::   zresm                                                    ! Maximal error on ice velocity 
     130      REAL(wp) ::   zintb, zintn                                             ! dummy argument 
    144131       
    145       REAL(wp), POINTER, DIMENSION(:,:) ::   zdt              ! tension at centre of grid cells 
    146       REAL(wp), POINTER, DIMENSION(:,:) ::   zds              ! Shear on northeast corner of grid cells 
    147       REAL(wp), POINTER, DIMENSION(:,:) ::   zs1   , zs2      ! Diagonal stress tensor components zs1 and zs2  
    148       REAL(wp), POINTER, DIMENSION(:,:) ::   zs12             ! Non-diagonal stress tensor component zs12 
    149       REAL(wp), POINTER, DIMENSION(:,:) ::   zu_ice, zv_ice, zresr   ! Local error on velocity 
    150       REAL(wp), POINTER, DIMENSION(:,:) ::   zpice            ! array used for the calculation of ice surface slope: 
    151                                                               !   ocean surface (ssh_m) if ice is not embedded 
    152                                                               !   ice top surface if ice is embedded    
    153  
    154       REAL(wp), PARAMETER               ::   zepsi = 1.0e-20_wp ! tolerance parameter 
    155       REAL(wp), PARAMETER               ::   zvmin = 1.0e-03_wp ! ice volume below which ice velocity equals ocean velocity 
     132      REAL(wp), POINTER, DIMENSION(:,:) ::   zpresh                          ! temporary array for ice strength 
     133      REAL(wp), POINTER, DIMENSION(:,:) ::   z1_e1t0, z1_e2t0                ! scale factors 
     134      REAL(wp), POINTER, DIMENSION(:,:) ::   zp_delt                         ! P/delta at T points 
     135      ! 
     136      REAL(wp), POINTER, DIMENSION(:,:) ::   zaU   , zaV                     ! ice fraction on U/V points 
     137      REAL(wp), POINTER, DIMENSION(:,:) ::   zmU_t, zmV_t                    ! ice/snow mass/dt on U/V points 
     138      REAL(wp), POINTER, DIMENSION(:,:) ::   zmf                             ! coriolis parameter at T points 
     139      REAL(wp), POINTER, DIMENSION(:,:) ::   zTauU_ia , ztauV_ia             ! ice-atm. stress at U-V points 
     140      REAL(wp), POINTER, DIMENSION(:,:) ::   zspgU , zspgV                   ! surface pressure gradient at U/V points 
     141      REAL(wp), POINTER, DIMENSION(:,:) ::   v_oceU, u_oceV, v_iceU, u_iceV  ! ocean/ice u/v component on V/U points                            
     142      REAL(wp), POINTER, DIMENSION(:,:) ::   zfU   , zfV                     ! internal stresses 
     143       
     144      REAL(wp), POINTER, DIMENSION(:,:) ::   zds                             ! shear 
     145      REAL(wp), POINTER, DIMENSION(:,:) ::   zs1, zs2, zs12                  ! stress tensor components 
     146      REAL(wp), POINTER, DIMENSION(:,:) ::   zu_ice, zv_ice, zresr           ! check convergence 
     147      REAL(wp), POINTER, DIMENSION(:,:) ::   zpice                           ! array used for the calculation of ice surface slope: 
     148                                                                             !   ocean surface (ssh_m) if ice is not embedded 
     149                                                                             !   ice top surface if ice is embedded    
     150      REAL(wp), POINTER, DIMENSION(:,:) ::   zswitchU, zswitchV              ! dummy arrays 
     151      REAL(wp), POINTER, DIMENSION(:,:) ::   zmaskU, zmaskV                  ! mask for ice presence 
     152      REAL(wp), POINTER, DIMENSION(:,:) ::   zfmask, zwf                     ! mask at F points for the ice 
     153 
     154      REAL(wp), PARAMETER               ::   zepsi  = 1.0e-20_wp             ! tolerance parameter 
     155      REAL(wp), PARAMETER               ::   zmmin  = 1._wp                  ! ice mass (kg/m2) below which ice velocity equals ocean velocity 
     156      REAL(wp), PARAMETER               ::   zshlat = 2._wp                  ! boundary condition for sea-ice velocity (2=no slip ; 0=free slip) 
    156157      !!------------------------------------------------------------------- 
    157158 
    158       CALL wrk_alloc( jpi,jpj, zpresh, zfrld1, zmass1, zcorl1, za1ct , zpreshc, zfrld2, zmass2, zcorl2, za2ct ) 
    159       CALL wrk_alloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    160       CALL wrk_alloc( jpi,jpj, zf1   , zu_ice, zf2   , zv_ice , zdt    , zds  ) 
    161       CALL wrk_alloc( jpi,jpj, zdt   , zds   , zs1   , zs2   , zs12   , zresr , zpice                 ) 
     159      CALL wrk_alloc( jpi,jpj, zpresh, z1_e1t0, z1_e2t0, zp_delt ) 
     160      CALL wrk_alloc( jpi,jpj, zaU, zaV, zmU_t, zmV_t, zmf, zTauU_ia, ztauV_ia ) 
     161      CALL wrk_alloc( jpi,jpj, zspgU, zspgV, v_oceU, u_oceV, v_iceU, u_iceV, zfU, zfV ) 
     162      CALL wrk_alloc( jpi,jpj, zds, zs1, zs2, zs12, zu_ice, zv_ice, zresr, zpice ) 
     163      CALL wrk_alloc( jpi,jpj, zswitchU, zswitchV, zmaskU, zmaskV, zfmask, zwf ) 
    162164 
    163165#if  defined key_lim2 && ! defined key_lim2_vp 
    … …  
    176178      ! 
    177179      !------------------------------------------------------------------------------! 
    178       ! 1) Ice strength (zpresh)                                ! 
    179       !------------------------------------------------------------------------------! 
    180       ! 
    181       ! Put every vector to 0 
    182       delta_i(:,:) = 0._wp   ; 
    183       zpresh (:,:) = 0._wp   ;   
    184       zpreshc(:,:) = 0._wp 
    185       u_ice2 (:,:) = 0._wp   ;   v_ice1(:,:) = 0._wp 
    186       divu_i (:,:) = 0._wp   ;   zdt   (:,:) = 0._wp   ;   zds(:,:) = 0._wp 
    187       shear_i(:,:) = 0._wp 
    188  
     180      ! 0) mask at F points for the ice (on the whole domain, not only k_j1,k_jpj)  
     181      !------------------------------------------------------------------------------! 
     182      ! ocean/land mask 
     183      DO jj = 1, jpjm1 
     184         DO ji = 1, jpim1      ! NO vector opt. 
     185            zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 
     186         END DO 
     187      END DO 
     188      CALL lbc_lnk( zfmask, 'F', 1._wp ) 
     189 
     190      ! Lateral boundary conditions on velocity (modify zfmask) 
     191      zwf(:,:) = zfmask(:,:) 
     192      DO jj = 2, jpjm1 
     193         DO ji = fs_2, fs_jpim1   ! vector opt. 
     194            IF( zfmask(ji,jj) == 0._wp ) THEN 
     195               zfmask(ji,jj) = zshlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), zwf(ji-1,jj), zwf(ji,jj-1) ) ) 
     196            ENDIF 
     197         END DO 
     198      END DO 
     199      DO jj = 2, jpjm1 
     200         IF( zfmask(1,jj) == 0._wp ) THEN 
     201            zfmask(1  ,jj) = zshlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) ) 
     202         ENDIF 
     203         IF( zfmask(jpi,jj) == 0._wp ) THEN 
     204            zfmask(jpi,jj) = zshlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) ) 
     205         ENDIF 
     206      END DO 
     207      DO ji = 2, jpim1 
     208         IF( zfmask(ji,1) == 0._wp ) THEN 
     209            zfmask(ji,1  ) = zshlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) ) 
     210         ENDIF 
     211         IF( zfmask(ji,jpj) == 0._wp ) THEN 
     212            zfmask(ji,jpj) = zshlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) ) 
     213         ENDIF 
     214      END DO 
     215      CALL lbc_lnk( zfmask, 'F', 1._wp ) 
     216 
     217      !------------------------------------------------------------------------------! 
     218      ! 1) define some variables and initialize arrays 
     219      !------------------------------------------------------------------------------! 
     220      ! ecc2: square of yield ellipse eccenticrity 
     221      ecc2    = rn_ecc * rn_ecc 
     222      z1_ecc2 = 1._wp / ecc2 
     223 
     224      ! Time step for subcycling 
     225      zdtevp   = rdt_ice / REAL( nn_nevp ) 
     226      z1_dtevp = 1._wp / zdtevp 
     227 
     228      ! alpha parameters (Bouillon 2009) 
    189229#if defined key_lim3 
    190       CALL lim_itd_me_icestrength( nn_icestr )      ! LIM-3: Ice strength on T-points 
    191 #endif 
    192  
    193       DO jj = k_j1 , k_jpj       ! Ice mass and temp variables 
    194          DO ji = 1 , jpi 
     230      zalph1 = ( 2._wp * rn_relast * rdt_ice ) * z1_dtevp 
     231#else 
     232      zalph1 = ( 2._wp * telast ) * z1_dtevp 
     233#endif 
     234      zalph2 = zalph1 * z1_ecc2 
     235 
     236      z1_alph1 = 1._wp / ( zalph1 + 1._wp ) 
     237      z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 
     238 
     239      ! Initialise stress tensor  
     240      zs1 (:,:) = stress1_i (:,:)  
     241      zs2 (:,:) = stress2_i (:,:) 
     242      zs12(:,:) = stress12_i(:,:) 
     243 
     244      ! Ice strength 
    195245#if defined key_lim3 
    196             zpresh(ji,jj) = tmask(ji,jj,1) *  strength(ji,jj) 
    197 #endif 
    198 #if defined key_lim2 
    199             zpresh(ji,jj) = tmask(ji,jj,1) *  pstar * vt_i(ji,jj) * EXP( -c_rhg * (1. - at_i(ji,jj) ) ) 
    200 #endif 
    201             ! zmask = 1 where there is ice or on land 
    202             zmask(ji,jj)    = 1._wp - ( 1._wp - MAX( 0._wp , SIGN ( 1._wp , vt_i(ji,jj) - zepsi ) ) ) * tmask(ji,jj,1) 
     246      CALL lim_itd_me_icestrength( nn_icestr ) 
     247      zpresh(:,:) = tmask(:,:,1) *  strength(:,:) 
     248#else 
     249      zpresh(:,:) = tmask(:,:,1) *  pstar * vt_i(:,:) * EXP( -c_rhg * (1. - at_i(:,:) ) ) 
     250#endif 
     251 
     252      ! scale factors 
     253      DO jj = k_j1+1, k_jpj-1 
     254         DO ji = fs_2, fs_jpim1 
     255            z1_e1t0(ji,jj) = 1._wp / ( e1t(ji+1,jj  ) + e1t(ji,jj  ) ) 
     256            z1_e2t0(ji,jj) = 1._wp / ( e2t(ji  ,jj+1) + e2t(ji,jj  ) ) 
    203257         END DO 
    204258      END DO 
    205  
    206       ! Ice strength on grid cell corners (zpreshc) 
    207       ! needed for calculation of shear stress  
    208       DO jj = k_j1+1, k_jpj-1 
    209          DO ji = 2, jpim1 !RB caution no fs_ (ji+1,jj+1) 
    210             zstms          =  tmask(ji+1,jj+1,1) * wght(ji+1,jj+1,2,2) + tmask(ji,jj+1,1) * wght(ji+1,jj+1,1,2) +   & 
    211                &              tmask(ji+1,jj,1)   * wght(ji+1,jj+1,2,1) + tmask(ji,jj,1)   * wght(ji+1,jj+1,1,1) 
    212             zpreshc(ji,jj) = ( zpresh(ji+1,jj+1) * wght(ji+1,jj+1,2,2) + zpresh(ji,jj+1) * wght(ji+1,jj+1,1,2) +   & 
    213                &               zpresh(ji+1,jj)   * wght(ji+1,jj+1,2,1) + zpresh(ji,jj)   * wght(ji+1,jj+1,1,1)     & 
    214                &             ) / MAX( zstms, zepsi ) 
    215          END DO 
    216       END DO 
    217       CALL lbc_lnk( zpreshc(:,:), 'F', 1. ) 
     259             
    218260      ! 
    219261      !------------------------------------------------------------------------------! 
    220262      ! 2) Wind / ocean stress, mass terms, coriolis terms 
    221263      !------------------------------------------------------------------------------! 
    222       ! 
    223       !  Wind stress, coriolis and mass terms on the sides of the squares         
    224       !  zfrld1: lead fraction on U-points                                       
    225       !  zfrld2: lead fraction on V-points                                      
    226       !  zmass1: ice/snow mass on U-points                                     
    227       !  zmass2: ice/snow mass on V-points                                    
    228       !  zcorl1: Coriolis parameter on U-points                              
    229       !  zcorl2: Coriolis parameter on V-points                             
    230       !  (ztagnx,ztagny): wind stress on U/V points                        
    231       !  v_oce1: ocean v component on u points                           
    232       !  u_oce2: ocean u component on v points                          
    233264 
    234265      IF( nn_ice_embd == 2 ) THEN             !== embedded sea ice: compute representative ice top surface ==! 
    … …  
    242273         zintb = REAL( nn_fsbc + 1 ) / REAL( nn_fsbc ) * 0.5_wp 
    243274         ! 
    244          zpice(:,:) = ssh_m(:,:) + (  zintn * snwice_mass(:,:) +  zintb * snwice_mass_b(:,:) ) * r1_rau0 
     275         zpice(:,:) = ssh_m(:,:) + ( zintn * snwice_mass(:,:) + zintb * snwice_mass_b(:,:) ) * r1_rau0 
    245276         ! 
    246277      ELSE                                    !== non-embedded sea ice: use ocean surface for slope calculation ==! 
    … …  
    251282         DO ji = fs_2, fs_jpim1 
    252283 
    253             zc1 = tmask(ji  ,jj  ,1) * ( rhosn * vt_s(ji  ,jj  ) + rhoic * vt_i(ji  ,jj  ) ) 
    254             zc2 = tmask(ji+1,jj  ,1) * ( rhosn * vt_s(ji+1,jj  ) + rhoic * vt_i(ji+1,jj  ) ) 
    255             zc3 = tmask(ji  ,jj+1,1) * ( rhosn * vt_s(ji  ,jj+1) + rhoic * vt_i(ji  ,jj+1) ) 
    256  
    257             zt11 = tmask(ji  ,jj,1) * e1t(ji  ,jj) 
    258             zt12 = tmask(ji+1,jj,1) * e1t(ji+1,jj) 
    259             zt21 = tmask(ji,jj  ,1) * e2t(ji,jj  ) 
    260             zt22 = tmask(ji,jj+1,1) * e2t(ji,jj+1) 
    261  
    262             ! Leads area. 
    263             zfrld1(ji,jj) = ( zt12 * ( 1.0 - at_i(ji,jj) ) + zt11 * ( 1.0 - at_i(ji+1,jj) ) ) / ( zt11 + zt12 + zepsi ) 
    264             zfrld2(ji,jj) = ( zt22 * ( 1.0 - at_i(ji,jj) ) + zt21 * ( 1.0 - at_i(ji,jj+1) ) ) / ( zt21 + zt22 + zepsi ) 
    265  
    266             ! Mass, coriolis coeff. and currents 
    267             zmass1(ji,jj) = ( zt12 * zc1 + zt11 * zc2 ) / ( zt11 + zt12 + zepsi ) 
    268             zmass2(ji,jj) = ( zt22 * zc1 + zt21 * zc3 ) / ( zt21 + zt22 + zepsi ) 
    269             zcorl1(ji,jj) = zmass1(ji,jj) * ( e1t(ji+1,jj) * fcor(ji,jj) + e1t(ji,jj) * fcor(ji+1,jj) )   & 
    270                &                          / ( e1t(ji,jj) + e1t(ji+1,jj) + zepsi ) 
    271             zcorl2(ji,jj) = zmass2(ji,jj) * ( e2t(ji,jj+1) * fcor(ji,jj) + e2t(ji,jj) * fcor(ji,jj+1) )   & 
    272                &                          / ( e2t(ji,jj+1) + e2t(ji,jj) + zepsi ) 
    273             ! 
    274             ! Ocean has no slip boundary condition 
    275             v_oce1(ji,jj)  = 0.5 * ( ( v_oce(ji  ,jj) + v_oce(ji  ,jj-1) ) * e1t(ji,jj)      & 
    276                &                   + ( v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * e1t(ji+1,jj) )  & 
    277                &                   / ( e1t(ji+1,jj) + e1t(ji,jj) ) * umask(ji,jj,1)   
    278  
    279             u_oce2(ji,jj)  = 0.5 * ( ( u_oce(ji,jj  ) + u_oce(ji-1,jj  ) ) * e2t(ji,jj)      & 
    280                &                   + ( u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * e2t(ji,jj+1) )  & 
    281                &                   / ( e2t(ji,jj+1) + e2t(ji,jj) ) * vmask(ji,jj,1) 
    282  
    283             ! Wind stress at U,V-point 
    284             ztagnx = ( 1. - zfrld1(ji,jj) ) * utau_ice(ji,jj) 
    285             ztagny = ( 1. - zfrld2(ji,jj) ) * vtau_ice(ji,jj) 
    286  
    287             ! Computation of the velocity field taking into account the ice internal interaction. 
    288             ! Terms that are independent of the velocity field. 
    289  
    290             ! SB On utilise maintenant le gradient de la pente de l'ocean 
    291             ! include it later 
    292  
    293             zdsshx =  ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj) 
    294             zdsshy =  ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj) 
    295  
    296             za1ct(ji,jj) = ztagnx - zmass1(ji,jj) * grav * zdsshx 
    297             za2ct(ji,jj) = ztagny - zmass2(ji,jj) * grav * zdsshy 
     284            ! ice fraction at U-V points 
     285            zaU(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e12t(ji,jj) + at_i(ji+1,jj) * e12t(ji+1,jj) ) * r1_e12u(ji,jj) * umask(ji,jj,1) 
     286            zaV(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e12t(ji,jj) + at_i(ji,jj+1) * e12t(ji,jj+1) ) * r1_e12v(ji,jj) * vmask(ji,jj,1) 
     287 
     288            ! Ice/snow mass at U-V points 
     289            zm1 = ( rhosn * vt_s(ji  ,jj  ) + rhoic * vt_i(ji  ,jj  ) ) 
     290            zm2 = ( rhosn * vt_s(ji+1,jj  ) + rhoic * vt_i(ji+1,jj  ) ) 
     291            zm3 = ( rhosn * vt_s(ji  ,jj+1) + rhoic * vt_i(ji  ,jj+1) ) 
     292            zmassU = 0.5_wp * ( zm1 * e12t(ji,jj) + zm2 * e12t(ji+1,jj) ) * r1_e12u(ji,jj) * umask(ji,jj,1) 
     293            zmassV = 0.5_wp * ( zm1 * e12t(ji,jj) + zm3 * e12t(ji,jj+1) ) * r1_e12v(ji,jj) * vmask(ji,jj,1) 
     294 
     295            ! Ocean currents at U-V points 
     296            v_oceU(ji,jj)   = 0.5_wp * ( ( v_oce(ji  ,jj) + v_oce(ji  ,jj-1) ) * e1t(ji+1,jj)    & 
     297               &                       + ( v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * e1t(ji  ,jj) ) * z1_e1t0(ji,jj) * umask(ji,jj,1) 
     298             
     299            u_oceV(ji,jj)   = 0.5_wp * ( ( u_oce(ji,jj  ) + u_oce(ji-1,jj  ) ) * e2t(ji,jj+1)    & 
     300               &                       + ( u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * e2t(ji,jj  ) ) * z1_e2t0(ji,jj) * vmask(ji,jj,1) 
     301 
     302            ! Coriolis at T points (m*f) 
     303            zmf(ji,jj)      = zm1 * fcor(ji,jj) 
     304 
     305            ! m/dt 
     306            zmU_t(ji,jj)    = zmassU * z1_dtevp 
     307            zmV_t(ji,jj)    = zmassV * z1_dtevp 
     308 
     309            ! Drag ice-atm. 
     310            zTauU_ia(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) 
     311            zTauV_ia(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj) 
     312 
     313            ! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points 
     314            zspgU(ji,jj)    = - zmassU * grav * ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj) 
     315            zspgV(ji,jj)    = - zmassV * grav * ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj) 
     316 
     317            ! masks 
     318            zmaskU(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) )  ! 0 if no ice 
     319            zmaskV(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) )  ! 0 if no ice 
     320 
     321            ! switches 
     322            zswitchU(ji,jj) = MAX( 0._wp, SIGN( 1._wp, zmassU - zmmin ) ) ! 0 if ice mass < zmmin 
     323            zswitchV(ji,jj) = MAX( 0._wp, SIGN( 1._wp, zmassV - zmmin ) ) ! 0 if ice mass < zmmin 
    298324 
    299325         END DO 
    300326      END DO 
    301  
     327      CALL lbc_lnk( zmf, 'T', 1. ) 
    302328      ! 
    303329      !------------------------------------------------------------------------------! 
    … …  
    305331      !------------------------------------------------------------------------------! 
    306332      ! 
    307       ! Time step for subcycling 
    308       dtevp  = rdt_ice / nn_nevp 
    309 #if defined key_lim3 
    310       dtotel = dtevp / ( 2._wp * rn_relast * rdt_ice ) 
    311 #else 
    312       dtotel = dtevp / ( 2._wp * telast ) 
    313 #endif 
    314       z1_dtotel = 1._wp / ( 1._wp + dtotel ) 
    315       z1_dtevp  = 1._wp / dtevp 
    316       !-ecc2: square of yield ellipse eccenticrity (reminder: must become a namelist parameter) 
    317       ecc2 = rn_ecc * rn_ecc 
    318       ecci = 1. / ecc2 
    319  
    320       !-Initialise stress tensor  
    321       zs1 (:,:) = stress1_i (:,:)  
    322       zs2 (:,:) = stress2_i (:,:) 
    323       zs12(:,:) = stress12_i(:,:) 
    324  
    325333      !                                               !----------------------! 
    326334      DO jter = 1 , nn_nevp                           !    loop over jter    ! 
    327335         !                                            !----------------------!         
    328          DO jj = k_j1, k_jpj-1 
    329             zu_ice(:,jj) = u_ice(:,jj)    ! velocity at previous time step 
    330             zv_ice(:,jj) = v_ice(:,jj) 
    331          END DO 
    332  
    333          DO jj = k_j1+1, k_jpj-1 
    334             DO ji = fs_2, fs_jpim1   !RB bug no vect opt due to zmask 
    335  
    336                !   
    337                !- Divergence, tension and shear (Section a. Appendix B of Hunke & Dukowicz, 2002) 
    338                !- divu_i(:,:), zdt(:,:): divergence and tension at centre of grid cells 
    339                !- zds(:,:): shear on northeast corner of grid cells 
    340                ! 
    341                !- IMPORTANT REMINDER: Dear Gurvan, note that, the way these terms are coded,  
    342                !                      there are many repeated calculations.  
    343                !                      Speed could be improved by regrouping terms. For 
    344                !                      the moment, however, the stress is on clarity of coding to avoid 
    345                !                      bugs (Martin, for Miguel). 
    346                ! 
    347                !- ALSO: arrays zdt, zds and delta could  
    348                !  be removed in the future to minimise memory demand. 
    349                ! 
    350                !- MORE NOTES: Note that we are calculating deformation rates and stresses on the corners of 
    351                !              grid cells, exactly as in the B grid case. For simplicity, the indexation on 
    352                !              the corners is the same as in the B grid. 
    353                ! 
    354                ! 
    355                divu_i(ji,jj) = (  e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    356                   &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
    357                   &            ) * r1_e12t(ji,jj) 
    358  
    359                zdt(ji,jj) = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
    360                   &         - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
    361                   &         ) * r1_e12t(ji,jj) 
    362  
    363                ! 
     336         IF(ln_ctl) THEN   ! Convergence test 
     337            DO jj = k_j1, k_jpj-1 
     338               zu_ice(:,jj) = u_ice(:,jj) ! velocity at previous time step 
     339               zv_ice(:,jj) = v_ice(:,jj) 
     340            END DO 
     341         ENDIF 
     342 
     343         ! --- divergence, tension & shear (Appendix B of Hunke & Dukowicz, 2002) --- ! 
     344         DO jj = k_j1, k_jpj-1         ! loops start at 1 since there is no boundary condition (lbc_lnk) at i=1 and j=1 for F points 
     345            DO ji = 1, jpim1 
     346 
     347               ! shear at F points 
    364348               zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)   & 
    365349                  &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
    366                   &         ) * r1_e12f(ji,jj) * ( 2._wp - fmask(ji,jj,1) )   & 
    367                   &         * zmask(ji,jj) * zmask(ji,jj+1) * zmask(ji+1,jj) * zmask(ji+1,jj+1) 
    368  
    369  
    370                v_ice1(ji,jj)  = 0.5_wp * ( ( v_ice(ji  ,jj) + v_ice(ji  ,jj-1) ) * e1t(ji+1,jj)     & 
    371                   &                      + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * e1t(ji  ,jj) )   & 
    372                   &                      / ( e1t(ji+1,jj) + e1t(ji,jj) ) * umask(ji,jj,1)  
    373  
    374                u_ice2(ji,jj)  = 0.5_wp * ( ( u_ice(ji,jj  ) + u_ice(ji-1,jj  ) ) * e2t(ji,jj+1)     & 
    375                   &                      + ( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * e2t(ji,jj  ) )   & 
    376                   &                      / ( e2t(ji,jj+1) + e2t(ji,jj) ) * vmask(ji,jj,1) 
    377             END DO 
    378          END DO 
    379  
    380          CALL lbc_lnk_multi( v_ice1, 'U', -1., u_ice2, 'V', -1. )      ! lateral boundary cond. 
    381           
     350                  &         ) * r1_e12f(ji,jj) * zfmask(ji,jj) 
     351 
     352            END DO 
     353         END DO 
     354         CALL lbc_lnk( zds, 'F', 1. ) 
     355 
    382356         DO jj = k_j1+1, k_jpj-1 
    383             DO ji = fs_2, fs_jpim1 
    384  
    385                !- Calculate Delta at centre of grid cells 
    386                zdst          = ( e2u(ji,jj) * v_ice1(ji,jj) - e2u(ji-1,jj  ) * v_ice1(ji-1,jj  )   & 
    387                   &            + e1v(ji,jj) * u_ice2(ji,jj) - e1v(ji  ,jj-1) * u_ice2(ji  ,jj-1)   & 
    388                   &            ) * r1_e12t(ji,jj) 
    389  
    390                delta          = SQRT( divu_i(ji,jj)**2 + ( zdt(ji,jj)**2 + zdst**2 ) * usecc2 )   
    391                delta_i(ji,jj) = delta + rn_creepl 
    392  
    393                !- Calculate Delta on corners 
    394                zddc  = (  ( v_ice1(ji,jj+1) * r1_e1u(ji,jj+1) - v_ice1(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)  & 
    395                   &     + ( u_ice2(ji+1,jj) * r1_e2v(ji+1,jj) - u_ice2(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)  & 
    396                   &    ) * r1_e12f(ji,jj) 
    397  
    398                zdtc  = (- ( v_ice1(ji,jj+1) * r1_e1u(ji,jj+1) - v_ice1(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)  & 
    399                   &     + ( u_ice2(ji+1,jj) * r1_e2v(ji+1,jj) - u_ice2(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)  & 
    400                   &    ) * r1_e12f(ji,jj) 
    401  
    402                zddc = SQRT( zddc**2 + ( zdtc**2 + zds(ji,jj)**2 ) * usecc2 ) + rn_creepl 
    403  
    404                !-Calculate stress tensor components zs1 and zs2 at centre of grid cells (see section 3.5 of CICE user's guide). 
    405                zs1(ji,jj)  = ( zs1 (ji,jj) + dtotel * ( divu_i(ji,jj) - delta ) / delta_i(ji,jj)   * zpresh(ji,jj)   & 
    406                   &          ) * z1_dtotel 
    407                zs2(ji,jj)  = ( zs2 (ji,jj) + dtotel *         ecci * zdt(ji,jj) / delta_i(ji,jj)   * zpresh(ji,jj)   & 
    408                   &          ) * z1_dtotel 
    409                !-Calculate stress tensor component zs12 at corners 
    410                zs12(ji,jj) = ( zs12(ji,jj) + dtotel *         ecci * zds(ji,jj) / ( 2._wp * zddc ) * zpreshc(ji,jj)  & 
    411                   &          ) * z1_dtotel  
    412  
    413             END DO 
    414          END DO 
    415  
    416          CALL lbc_lnk_multi( zs1 , 'T', 1., zs2, 'T', 1., zs12, 'F', 1. ) 
     357            DO ji = 2, jpim1 ! no vector loop 
     358 
     359               ! shear**2 at T points (doc eq. A16) 
     360               zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e12f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e12f(ji-1,jj  )  & 
     361                  &   + zds(ji,jj-1) * zds(ji,jj-1) * e12f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e12f(ji-1,jj-1)  & 
     362                  &   ) * 0.25_wp * r1_e12t(ji,jj) 
     363               
     364               ! divergence at T points 
     365               zdiv  = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     366                  &    + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
     367                  &    ) * r1_e12t(ji,jj) 
     368               zdiv2 = zdiv * zdiv 
     369                
     370               ! tension at T points 
     371               zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
     372                  &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
     373                  &   ) * r1_e12t(ji,jj) 
     374               zdt2 = zdt * zdt 
     375                
     376               ! delta at T points 
     377               zdelta = SQRT( zdiv2 + ( zdt2 + zds2 ) * usecc2 )   
     378 
     379               ! P/delta at T points 
     380               zp_delt(ji,jj) = zpresh(ji,jj) / ( zdelta + rn_creepl ) 
     381                
     382               ! stress at T points 
     383               zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zp_delt(ji,jj) * ( zdiv - zdelta ) ) * z1_alph1 
     384               zs2(ji,jj) = ( zs2(ji,jj) * zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 ) ) * z1_alph2 
     385              
     386            END DO 
     387         END DO 
     388         CALL lbc_lnk( zp_delt, 'T', 1. ) 
     389 
     390         DO jj = k_j1, k_jpj-1 
     391            DO ji = 1, jpim1 
     392 
     393               ! P/delta at F points 
     394               zp_delf = 0.25_wp * ( zp_delt(ji,jj) + zp_delt(ji+1,jj) + zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1) ) 
     395                
     396               ! stress at F points 
     397               zs12(ji,jj)= ( zs12(ji,jj) * zalph2 + zp_delf * ( zds(ji,jj) * z1_ecc2 ) * 0.5_wp ) * z1_alph2 
     398 
     399            END DO 
     400         END DO 
     401         CALL lbc_lnk_multi( zs1, 'T', 1., zs2, 'T', 1., zs12, 'F', 1. ) 
    417402  
    418          ! Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) 
     403         ! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- ! 
    419404         DO jj = k_j1+1, k_jpj-1 
    420             DO ji = fs_2, fs_jpim1 
    421                !- contribution of zs1, zs2 and zs12 to zf1 
    422                zf1(ji,jj) = 0.5 * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj)  & 
    423                   &             + ( zs2(ji+1,jj) * e2t(ji+1,jj)**2 - zs2(ji,jj) * e2t(ji,jj)**2 ) * r1_e2u(ji,jj)          & 
    424                   &             + 2.0 * ( zs12(ji,jj) * e1f(ji,jj)**2 - zs12(ji,jj-1) * e1f(ji,jj-1)**2 ) * r1_e1u(ji,jj)  & 
    425                   &                ) * r1_e12u(ji,jj) 
    426                ! contribution of zs1, zs2 and zs12 to zf2 
    427                zf2(ji,jj) = 0.5 * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj)  & 
    428                   &             - ( zs2(ji,jj+1) * e1t(ji,jj+1)**2 - zs2(ji,jj) * e1t(ji,jj)**2 ) * r1_e1v(ji,jj)          & 
    429                   &             + 2.0 * ( zs12(ji,jj) * e2f(ji,jj)**2 - zs12(ji-1,jj) * e2f(ji-1,jj)**2 ) * r1_e2v(ji,jj)  & 
    430                   &               )  * r1_e12v(ji,jj) 
     405            DO ji = fs_2, fs_jpim1                
     406 
     407               ! U points 
     408               zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj)                                             & 
     409                  &                  + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj)    & 
     410                  &                    ) * r1_e2u(ji,jj)                                                                      & 
     411                  &                  + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1)  & 
     412                  &                    ) * 2._wp * r1_e1u(ji,jj)                                                              & 
     413                  &                  ) * r1_e12u(ji,jj) 
     414 
     415               ! V points 
     416               zfV(ji,jj) = 0.5_wp * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj)                                             & 
     417                  &                  - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj)    & 
     418                  &                    ) * r1_e1v(ji,jj)                                                                      & 
     419                  &                  + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj)  & 
     420                  &                    ) * 2._wp * r1_e2v(ji,jj)                                                              & 
     421                  &                  ) * r1_e12v(ji,jj) 
     422 
     423               ! u_ice at V point 
     424               u_iceV(ji,jj) = 0.5_wp * ( ( u_ice(ji,jj  ) + u_ice(ji-1,jj  ) ) * e2t(ji,jj+1)     & 
     425                  &                     + ( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * e2t(ji,jj  ) ) * z1_e2t0(ji,jj) * vmask(ji,jj,1) 
     426                
     427               ! v_ice at U point 
     428               v_iceU(ji,jj) = 0.5_wp * ( ( v_ice(ji  ,jj) + v_ice(ji  ,jj-1) ) * e1t(ji+1,jj)     & 
     429                  &                     + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * e1t(ji  ,jj) ) * z1_e1t0(ji,jj) * umask(ji,jj,1) 
     430 
    431431            END DO 
    432432         END DO 
    433433         ! 
    434          ! Computation of ice velocity 
    435          ! 
    436          ! Both the Coriolis term and the ice-ocean drag are solved semi-implicitly. 
    437          ! 
    438          IF (MOD(jter,2).eq.0) THEN  
    439  
     434         ! --- Computation of ice velocity --- ! 
     435         !  Bouillon et al. 2013 (eq 47-48) => unstable unless alpha, beta are chosen wisely and large nn_nevp 
     436         !  Bouillon et al. 2009 (eq 34-35) => stable 
     437         IF( MOD(jter,2) .EQ. 0 ) THEN ! even iterations 
     438             
    440439            DO jj = k_j1+1, k_jpj-1 
    441440               DO ji = fs_2, fs_jpim1 
    442                   rswitch      = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zmass1(ji,jj) ) ) ) * umask(ji,jj,1) 
    443                   z0           = zmass1(ji,jj) * z1_dtevp 
    444  
    445                   ! SB modif because ocean has no slip boundary condition 
    446                   zv_ice1      = 0.5 * ( ( v_ice(ji  ,jj) + v_ice(ji  ,jj-1) ) * e1t(ji  ,jj)     & 
    447                      &                 + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * e1t(ji+1,jj) )   & 
    448                      &                 / ( e1t(ji+1,jj) + e1t(ji,jj) ) * umask(ji,jj,1) 
    449                   za           = rhoco * SQRT( ( u_ice(ji,jj) - u_oce(ji,jj) )**2 +  & 
    450                      &                         ( zv_ice1 - v_oce1(ji,jj) )**2 ) * ( 1.0 - zfrld1(ji,jj) ) 
    451                   zr           = z0 * u_ice(ji,jj) + zf1(ji,jj) + za1ct(ji,jj) + za * u_oce(ji,jj) 
    452                   zcca         = z0 + za 
    453                   zccb         = zcorl1(ji,jj) 
    454                   u_ice(ji,jj) = ( zr + zccb * zv_ice1 ) / ( zcca + zepsi ) * rswitch  
     441 
     442                  ! tau_io/(v_oce - v_ice) 
     443                  zTauO = zaV(ji,jj) * rhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  & 
     444                     &                             + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 
     445 
     446                  ! Coriolis at V-points (energy conserving formulation) 
     447                  zCor  = - 0.25_wp * r1_e2v(ji,jj) *  & 
     448                     &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  & 
     449                     &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 
     450 
     451                  ! Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     452                  zTauE = zfV(ji,jj) + zTauV_ia(ji,jj) + zCor + zspgV(ji,jj) + zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 
     453                   
     454                  ! ice velocity using implicit formulation (cf Madec doc & Bouillon 2009) 
     455                  v_ice(ji,jj) = ( ( zmV_t(ji,jj) * v_ice(ji,jj) + zTauE + zTauO * v_ice(ji,jj)  &  ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     456                     &             ) / MAX( zepsi, zmV_t(ji,jj) + zTauO ) * zswitchV(ji,jj)      &  ! m/dt + tau_io(only ice part) 
     457                     &             + v_oce(ji,jj) * ( 1._wp - zswitchV(ji,jj) )                  &  ! v_ice = v_oce if mass < zmmin 
     458                     &           ) * zmaskV(ji,jj) 
    455459               END DO 
    456460            END DO 
    457  
    458             CALL lbc_lnk( u_ice(:,:), 'U', -1. ) 
     461            CALL lbc_lnk( v_ice, 'V', -1. ) 
     462             
     463#if defined key_agrif && defined key_lim2 
     464            CALL agrif_rhg_lim2( jter, nn_nevp, 'V' ) 
     465#endif 
     466#if defined key_bdy 
     467            CALL bdy_ice_lim_dyn( 'V' ) 
     468#endif          
     469 
     470            DO jj = k_j1+1, k_jpj-1 
     471               DO ji = fs_2, fs_jpim1 
     472                                
     473                  ! tau_io/(u_oce - u_ice) 
     474                  zTauO = zaU(ji,jj) * rhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  & 
     475                     &                             + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 
     476 
     477                  ! Coriolis at U-points (energy conserving formulation) 
     478                  zCor  =   0.25_wp * r1_e1u(ji,jj) *  & 
     479                     &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  & 
     480                     &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 
     481                   
     482                  ! Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     483                  zTauE = zfU(ji,jj) + zTauU_ia(ji,jj) + zCor + zspgU(ji,jj) + zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 
     484 
     485                  ! ice velocity using implicit formulation (cf Madec doc & Bouillon 2009) 
     486                  u_ice(ji,jj) = ( ( zmU_t(ji,jj) * u_ice(ji,jj) + zTauE + zTauO * u_ice(ji,jj)  &  ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     487                     &             ) / MAX( zepsi, zmU_t(ji,jj) + zTauO ) * zswitchU(ji,jj)      &  ! m/dt + tau_io(only ice part) 
     488                     &             + u_oce(ji,jj) * ( 1._wp - zswitchU(ji,jj) )                  &  ! v_ice = v_oce if mass < zmmin  
     489                     &           ) * zmaskU(ji,jj) 
     490               END DO 
     491            END DO 
     492            CALL lbc_lnk( u_ice, 'U', -1. ) 
     493             
    459494#if defined key_agrif && defined key_lim2 
    460495            CALL agrif_rhg_lim2( jter, nn_nevp, 'U' ) 
    461496#endif 
    462497#if defined key_bdy 
    463          CALL bdy_ice_lim_dyn( 'U' ) 
     498            CALL bdy_ice_lim_dyn( 'U' ) 
    464499#endif          
     500 
     501         ELSE ! odd iterations 
    465502 
    466503            DO jj = k_j1+1, k_jpj-1 
    467504               DO ji = fs_2, fs_jpim1 
    468  
    469                   rswitch      = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zmass2(ji,jj) ) ) ) * vmask(ji,jj,1) 
    470                   z0           = zmass2(ji,jj) * z1_dtevp 
    471                   ! SB modif because ocean has no slip boundary condition 
    472                   zu_ice2      = 0.5 * ( ( u_ice(ji,jj  ) + u_ice(ji-1,jj  ) ) * e2t(ji,jj)       & 
    473                      &                 + ( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * e2t(ji,jj+1) )   & 
    474                      &                 / ( e2t(ji,jj+1) + e2t(ji,jj) ) * vmask(ji,jj,1) 
    475                   za           = rhoco * SQRT( ( zu_ice2 - u_oce2(ji,jj) )**2 +  &  
    476                      &                         ( v_ice(ji,jj) - v_oce(ji,jj))**2 ) * ( 1.0 - zfrld2(ji,jj) ) 
    477                   zr           = z0 * v_ice(ji,jj) + zf2(ji,jj) + za2ct(ji,jj) + za * v_oce(ji,jj) 
    478                   zcca         = z0 + za 
    479                   zccb         = zcorl2(ji,jj) 
    480                   v_ice(ji,jj) = ( zr - zccb * zu_ice2 ) / ( zcca + zepsi ) * rswitch 
     505                                
     506                  ! tau_io/(u_oce - u_ice) 
     507                  zTauO = zaU(ji,jj) * rhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  & 
     508                     &                             + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 
     509 
     510                  ! Coriolis at U-points (energy conserving formulation) 
     511                  zCor  =   0.25_wp * r1_e1u(ji,jj) *  & 
     512                     &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  & 
     513                     &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 
     514                   
     515                  ! Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     516                  zTauE = zfU(ji,jj) + zTauU_ia(ji,jj) + zCor + zspgU(ji,jj) + zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 
     517 
     518                  ! ice velocity using implicit formulation (cf Madec doc & Bouillon 2009) 
     519                  u_ice(ji,jj) = ( ( zmU_t(ji,jj) * u_ice(ji,jj) + zTauE + zTauO * u_ice(ji,jj)  &  ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     520                     &             ) / MAX( zepsi, zmU_t(ji,jj) + zTauO ) * zswitchU(ji,jj)      &  ! m/dt + tau_io(only ice part) 
     521                     &             + u_oce(ji,jj) * ( 1._wp - zswitchU(ji,jj) )                  &  ! v_ice = v_oce if mass < zmmin  
     522                     &           ) * zmaskU(ji,jj) 
    481523               END DO 
    482524            END DO 
    483  
    484             CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 
     525            CALL lbc_lnk( u_ice, 'U', -1. ) 
     526             
     527#if defined key_agrif && defined key_lim2 
     528            CALL agrif_rhg_lim2( jter, nn_nevp, 'U' ) 
     529#endif 
     530#if defined key_bdy 
     531            CALL bdy_ice_lim_dyn( 'U' ) 
     532#endif          
     533 
     534           DO jj = k_j1+1, k_jpj-1 
     535               DO ji = fs_2, fs_jpim1 
     536 
     537                  ! tau_io/(v_oce - v_ice) 
     538                  zTauO = zaV(ji,jj) * rhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  & 
     539                     &                             + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 
     540 
     541                  ! Coriolis at V-points (energy conserving formulation) 
     542                  zCor  = - 0.25_wp * r1_e2v(ji,jj) *  & 
     543                     &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  & 
     544                     &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 
     545 
     546                  ! Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     547                  zTauE = zfV(ji,jj) + zTauV_ia(ji,jj) + zCor + zspgV(ji,jj) + zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 
     548                   
     549                  ! ice velocity using implicit formulation (cf Madec doc & Bouillon 2009) 
     550                  v_ice(ji,jj) = ( ( zmV_t(ji,jj) * v_ice(ji,jj) + zTauE + zTauO * v_ice(ji,jj)  &  ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     551                     &             ) / MAX( zepsi, zmV_t(ji,jj) + zTauO ) * zswitchV(ji,jj)      &  ! m/dt + tau_io(only ice part) 
     552                     &             + v_oce(ji,jj) * ( 1._wp - zswitchV(ji,jj) )                  &  ! v_ice = v_oce if mass < zmmin 
     553                     &           ) * zmaskV(ji,jj) 
     554               END DO 
     555            END DO 
     556            CALL lbc_lnk( v_ice, 'V', -1. ) 
     557             
    485558#if defined key_agrif && defined key_lim2 
    486559            CALL agrif_rhg_lim2( jter, nn_nevp, 'V' ) 
    487560#endif 
    488561#if defined key_bdy 
    489          CALL bdy_ice_lim_dyn( 'V' ) 
     562            CALL bdy_ice_lim_dyn( 'V' ) 
    490563#endif          
    491564 
    492          ELSE  
     565         ENDIF 
     566          
     567         IF(ln_ctl) THEN   ! Convergence test 
    493568            DO jj = k_j1+1, k_jpj-1 
    494                DO ji = fs_2, fs_jpim1 
    495                   rswitch      = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zmass2(ji,jj) ) ) ) * vmask(ji,jj,1) 
    496                   z0           = zmass2(ji,jj) * z1_dtevp 
    497                   ! SB modif because ocean has no slip boundary condition 
    498                   zu_ice2      = 0.5 * ( ( u_ice(ji,jj  ) + u_ice(ji-1,jj  ) ) * e2t(ji,jj)       & 
    499                      &                  +( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * e2t(ji,jj+1) )   & 
    500                      &                 / ( e2t(ji,jj+1) + e2t(ji,jj) ) * vmask(ji,jj,1)    
    501  
    502                   za           = rhoco * SQRT( ( zu_ice2 - u_oce2(ji,jj) )**2 +  & 
    503                      &                         ( v_ice(ji,jj) - v_oce(ji,jj) )**2 ) * ( 1.0 - zfrld2(ji,jj) ) 
    504                   zr           = z0 * v_ice(ji,jj) + zf2(ji,jj) + za2ct(ji,jj) + za * v_oce(ji,jj) 
    505                   zcca         = z0 + za 
    506                   zccb         = zcorl2(ji,jj) 
    507                   v_ice(ji,jj) = ( zr - zccb * zu_ice2 ) / ( zcca + zepsi ) * rswitch 
    508                END DO 
    509             END DO 
    510  
    511             CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 
    512 #if defined key_agrif && defined key_lim2 
    513             CALL agrif_rhg_lim2( jter, nn_nevp, 'V' ) 
    514 #endif 
    515 #if defined key_bdy 
    516          CALL bdy_ice_lim_dyn( 'V' ) 
    517 #endif          
    518  
    519             DO jj = k_j1+1, k_jpj-1 
    520                DO ji = fs_2, fs_jpim1 
    521                   rswitch      = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zmass1(ji,jj) ) ) ) * umask(ji,jj,1) 
    522                   z0           = zmass1(ji,jj) * z1_dtevp 
    523                   zv_ice1      = 0.5 * ( ( v_ice(ji  ,jj) + v_ice(ji  ,jj-1) ) * e1t(ji,jj)       & 
    524                      &                 + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * e1t(ji+1,jj) )   & 
    525                      &                 / ( e1t(ji+1,jj) + e1t(ji,jj) ) * umask(ji,jj,1) 
    526  
    527                   za           = rhoco * SQRT( ( u_ice(ji,jj) - u_oce(ji,jj) )**2 +  & 
    528                      &                         ( zv_ice1 - v_oce1(ji,jj) )**2 ) * ( 1.0 - zfrld1(ji,jj) ) 
    529                   zr           = z0 * u_ice(ji,jj) + zf1(ji,jj) + za1ct(ji,jj) + za * u_oce(ji,jj) 
    530                   zcca         = z0 + za 
    531                   zccb         = zcorl1(ji,jj) 
    532                   u_ice(ji,jj) = ( zr + zccb * zv_ice1 ) / ( zcca + zepsi ) * rswitch  
    533                END DO 
    534             END DO 
    535  
    536             CALL lbc_lnk( u_ice(:,:), 'U', -1. ) 
    537 #if defined key_agrif && defined key_lim2 
    538             CALL agrif_rhg_lim2( jter, nn_nevp, 'U' ) 
    539 #endif 
    540 #if defined key_bdy 
    541          CALL bdy_ice_lim_dyn( 'U' ) 
    542 #endif          
    543  
    544          ENDIF 
    545           
    546          IF(ln_ctl) THEN 
    547             !---  Convergence test. 
    548             DO jj = k_j1+1 , k_jpj-1 
    549569               zresr(:,jj) = MAX( ABS( u_ice(:,jj) - zu_ice(:,jj) ), ABS( v_ice(:,jj) - zv_ice(:,jj) ) ) 
    550570            END DO 
    … …  
    552572            IF( lk_mpp )   CALL mpp_max( zresm )   ! max over the global domain 
    553573         ENDIF 
    554  
     574         ! 
    555575         !                                                ! ==================== ! 
    556576      END DO                                              !  end loop over jter  ! 
    … …  
    558578      ! 
    559579      !------------------------------------------------------------------------------! 
    560       ! 4) Prevent ice velocities when the ice is thin 
    561       !------------------------------------------------------------------------------! 
    562       ! If the ice volume is below zvmin then ice velocity should equal the 
    563       ! ocean velocity. This prevents high velocity when ice is thin 
    564       DO jj = k_j1+1, k_jpj-1 
    565          DO ji = fs_2, fs_jpim1 
    566             IF ( vt_i(ji,jj) <= zvmin ) THEN 
    567                u_ice(ji,jj) = u_oce(ji,jj) 
    568                v_ice(ji,jj) = v_oce(ji,jj) 
    569             ENDIF 
     580      ! 4) Recompute delta, shear and div (inputs for mechanical redistribution)  
     581      !------------------------------------------------------------------------------! 
     582      DO jj = k_j1, k_jpj-1  
     583         DO ji = 1, jpim1 
     584 
     585            ! shear at F points 
     586            zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)   & 
     587               &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
     588               &         ) * r1_e12f(ji,jj) * zfmask(ji,jj) 
     589 
     590         END DO 
     591      END DO            
     592      CALL lbc_lnk( zds, 'F', 1. ) 
     593       
     594      DO jj = k_j1+1, k_jpj-1  
     595         DO ji = 2, jpim1 ! no vector loop 
     596             
     597            ! tension**2 at T points 
     598            zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
     599               &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
     600               &   ) * r1_e12t(ji,jj) 
     601            zdt2 = zdt * zdt 
     602             
     603            ! shear**2 at T points (doc eq. A16) 
     604            zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e12f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e12f(ji-1,jj  )  & 
     605               &   + zds(ji,jj-1) * zds(ji,jj-1) * e12f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e12f(ji-1,jj-1)  & 
     606               &   ) * 0.25_wp * r1_e12t(ji,jj) 
     607             
     608            ! shear at T points 
     609            shear_i(ji,jj) = SQRT( zdt2 + zds2 ) 
     610 
     611            ! divergence at T points 
     612            divu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     613               &            + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
     614               &            ) * r1_e12t(ji,jj) 
     615             
     616            ! delta at T points 
     617            zdelta         = SQRT( divu_i(ji,jj) * divu_i(ji,jj) + ( zdt2 + zds2 ) * usecc2 )   
     618            rswitch        = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta ) ) ! 0 if delta=0 
     619            delta_i(ji,jj) = zdelta + rn_creepl * rswitch 
     620 
    570621         END DO 
    571622      END DO 
    572  
    573       CALL lbc_lnk_multi( u_ice(:,:), 'U', -1., v_ice(:,:), 'V', -1. ) 
    574  
    575 #if defined key_agrif && defined key_lim2 
    576       CALL agrif_rhg_lim2( nn_nevp , nn_nevp, 'U' ) 
    577       CALL agrif_rhg_lim2( nn_nevp , nn_nevp, 'V' ) 
    578 #endif 
    579 #if defined key_bdy 
    580       CALL bdy_ice_lim_dyn( 'U' ) 
    581       CALL bdy_ice_lim_dyn( 'V' ) 
    582 #endif          
    583  
    584       DO jj = k_j1+1, k_jpj-1  
    585          DO ji = fs_2, fs_jpim1 
    586             IF ( vt_i(ji,jj) <= zvmin ) THEN 
    587                v_ice1(ji,jj)  = 0.5_wp * ( ( v_ice(ji  ,jj) + v_ice(ji,  jj-1) ) * e1t(ji+1,jj)     & 
    588                   &                      + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * e1t(ji  ,jj) )   & 
    589                   &                      / ( e1t(ji+1,jj) + e1t(ji,jj) ) * umask(ji,jj,1) 
    590  
    591                u_ice2(ji,jj)  = 0.5_wp * ( ( u_ice(ji,jj  ) + u_ice(ji-1,jj  ) ) * e2t(ji,jj+1)     & 
    592                   &                      + ( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * e2t(ji,jj  ) )   & 
    593                   &                      / ( e2t(ji,jj+1) + e2t(ji,jj) ) * vmask(ji,jj,1) 
    594             ENDIF  
    595          END DO 
    596       END DO 
    597  
    598       CALL lbc_lnk_multi( u_ice2(:,:), 'V', -1., v_ice1(:,:), 'U', -1. ) 
    599  
    600       ! Recompute delta, shear and div, inputs for mechanical redistribution  
    601       DO jj = k_j1+1, k_jpj-1 
    602          DO ji = fs_2, jpim1   !RB bug no vect opt due to zmask 
    603             !- divu_i(:,:), zdt(:,:): divergence and tension at centre  
    604             !- zds(:,:): shear on northeast corner of grid cells 
    605             IF ( vt_i(ji,jj) <= zvmin ) THEN 
    606  
    607                divu_i(ji,jj) = (  e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj  ) * u_ice(ji-1,jj  )   & 
    608                   &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji  ,jj-1) * v_ice(ji  ,jj-1)   & 
    609                   &            ) * r1_e12t(ji,jj) 
    610  
    611                zdt(ji,jj) = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)  & 
    612                   &          -( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)  & 
    613                   &         ) * r1_e12t(ji,jj) 
    614                ! 
    615                ! SB modif because ocean has no slip boundary condition  
    616                zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)  & 
    617                   &          +( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)  & 
    618                   &         ) * r1_e12f(ji,jj) * ( 2.0 - fmask(ji,jj,1) )                                     & 
    619                   &         * zmask(ji,jj) * zmask(ji,jj+1) * zmask(ji+1,jj) * zmask(ji+1,jj+1) 
    620  
    621                zdst = ( e2u(ji,jj) * v_ice1(ji,jj) - e2u(ji-1,jj  ) * v_ice1(ji-1,jj  )    & 
    622                   &   + e1v(ji,jj) * u_ice2(ji,jj) - e1v(ji  ,jj-1) * u_ice2(ji  ,jj-1) ) * r1_e12t(ji,jj) 
    623  
    624                delta = SQRT( divu_i(ji,jj)**2 + ( zdt(ji,jj)**2 + zdst**2 ) * usecc2 )   
    625                delta_i(ji,jj) = delta + rn_creepl 
    626              
    627             ENDIF 
    628          END DO 
    629       END DO 
    630       ! 
    631       !------------------------------------------------------------------------------! 
    632       ! 5) Store stress tensor and its invariants 
    633       !------------------------------------------------------------------------------! 
    634       ! * Invariants of the stress tensor are required for limitd_me 
    635       !   (accelerates convergence and improves stability) 
    636       DO jj = k_j1+1, k_jpj-1 
    637          DO ji = fs_2, fs_jpim1 
    638             zdst           = (  e2u(ji,jj) * v_ice1(ji,jj) - e2u( ji-1, jj   ) * v_ice1(ji-1,jj)  &    
    639                &              + e1v(ji,jj) * u_ice2(ji,jj) - e1v( ji  , jj-1 ) * u_ice2(ji,jj-1) ) * r1_e12t(ji,jj)  
    640             shear_i(ji,jj) = SQRT( zdt(ji,jj) * zdt(ji,jj) + zdst * zdst ) 
    641          END DO 
    642       END DO 
    643  
    644       ! Lateral boundary condition 
    645       CALL lbc_lnk_multi( divu_i (:,:), 'T', 1., delta_i(:,:), 'T', 1.,  shear_i(:,:), 'T', 1. ) 
    646  
    647       ! * Store the stress tensor for the next time step 
     623      CALL lbc_lnk_multi( shear_i, 'T', 1., divu_i, 'T', 1., delta_i, 'T', 1. ) 
     624       
     625      ! --- Store the stress tensor for the next time step --- ! 
    648626      stress1_i (:,:) = zs1 (:,:) 
    649627      stress2_i (:,:) = zs2 (:,:) 
    … …  
    652630      ! 
    653631      !------------------------------------------------------------------------------! 
    654       ! 6) Control prints of residual and charge ellipse 
     632      ! 5) Control prints of residual and charge ellipse 
    655633      !------------------------------------------------------------------------------! 
    656634      ! 
    … …  
    675653               DO ji = 2, jpim1 
    676654                  IF (zpresh(ji,jj) > 1.0) THEN 
    677                      sigma1 = ( zs1(ji,jj) + (zs2(ji,jj)**2 + 4*zs12(ji,jj)**2 )**0.5 ) / ( 2*zpresh(ji,jj) )  
    678                      sigma2 = ( zs1(ji,jj) - (zs2(ji,jj)**2 + 4*zs12(ji,jj)**2 )**0.5 ) / ( 2*zpresh(ji,jj) ) 
     655                     zsig1 = ( zs1(ji,jj) + (zs2(ji,jj)**2 + 4*zs12(ji,jj)**2 )**0.5 ) / ( 2*zpresh(ji,jj) )  
     656                     zsig2 = ( zs1(ji,jj) - (zs2(ji,jj)**2 + 4*zs12(ji,jj)**2 )**0.5 ) / ( 2*zpresh(ji,jj) ) 
    679657                     WRITE(charout,FMT="('lim_rhg  :', I4, I4, D23.16, D23.16, D23.16, D23.16, A10)") 
    680658                     CALL prt_ctl_info(charout) 
    … …  
    687665      ENDIF 
    688666      ! 
    689       CALL wrk_dealloc( jpi,jpj, zpresh, zfrld1, zmass1, zcorl1, za1ct , zpreshc, zfrld2, zmass2, zcorl2, za2ct ) 
    690       CALL wrk_dealloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    691       CALL wrk_dealloc( jpi,jpj, zf1   , zu_ice, zf2   , zv_ice , zdt    , zds  ) 
    692       CALL wrk_dealloc( jpi,jpj, zdt   , zds   , zs1   , zs2   , zs12   , zresr , zpice                 ) 
     667      CALL wrk_dealloc( jpi,jpj, zpresh, z1_e1t0, z1_e2t0, zp_delt ) 
     668      CALL wrk_dealloc( jpi,jpj, zaU, zaV, zmU_t, zmV_t, zmf, zTauU_ia, ztauV_ia ) 
     669      CALL wrk_dealloc( jpi,jpj, zspgU, zspgV, v_oceU, u_oceV, v_iceU, u_iceV, zfU, zfV ) 
     670      CALL wrk_dealloc( jpi,jpj, zds, zs1, zs2, zs12, zu_ice, zv_ice, zresr, zpice ) 
     671      CALL wrk_dealloc( jpi,jpj, zswitchU, zswitchV, zmaskU, zmaskV, zfmask, zwf ) 
    693672 
    694673   END SUBROUTINE lim_rhg 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90

    r5602 r7256  
    9494      !!              - fr_i    : ice fraction 
    9595      !!              - tn_ice  : sea-ice surface temperature 
    96       !!              - alb_ice : sea-ice albedo (only useful in coupled mode) 
     96      !!              - alb_ice : sea-ice albedo (recomputed only for coupled mode) 
    9797      !! 
    9898      !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. 
    … …  
    106106      REAL(wp) ::   zqsr                                           ! New solar flux received by the ocean 
    107107      ! 
    108       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb_cs, zalb_os     ! 2D/3D workspace 
     108      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb_cs, zalb_os     ! 3D workspace 
     109      REAL(wp), POINTER, DIMENSION(:,:)   ::   zalb                 ! 2D workspace 
    109110      !!--------------------------------------------------------------------- 
    110111 
    111       ! make calls for heat fluxes before it is modified 
    112       IF( iom_use('qsr_oce') )   CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) )                                   !     solar flux at ocean surface 
    113       IF( iom_use('qns_oce') )   CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) )                   ! non-solar flux at ocean surface 
    114       IF( iom_use('qsr_ice') )   CALL iom_put( "qsr_ice" , SUM( qsr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) )                 !     solar flux at ice surface 
    115       IF( iom_use('qns_ice') )   CALL iom_put( "qns_ice" , SUM( qns_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) ! non-solar flux at ice surface 
    116       IF( iom_use('qtr_ice') )   CALL iom_put( "qtr_ice" , SUM( ftr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) )                 !     solar flux transmitted thru ice 
    117       IF( iom_use('qt_oce' ) )   CALL iom_put( "qt_oce"  , ( qsr_oce(:,:) + qns_oce(:,:) ) * pfrld(:,:) + qemp_oce(:,:) )   
    118       IF( iom_use('qt_ice' ) )   CALL iom_put( "qt_ice"  , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) )   & 
    119          &                                                      * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) 
    120       IF( iom_use('qemp_oce' ) )   CALL iom_put( "qemp_oce"  , qemp_oce(:,:) )   
    121       IF( iom_use('qemp_ice' ) )   CALL iom_put( "qemp_ice"  , qemp_ice(:,:) )   
    122  
    123       ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 
     112      ! make call for albedo output before it is modified 
     113      CALL wrk_alloc( jpi,jpj, zalb )     
     114 
     115      zalb(:,:) = 0._wp 
     116      WHERE     ( SUM( a_i_b, dim=3 ) <= epsi06 )  ;  zalb(:,:) = 0.066_wp 
     117      ELSEWHERE                                    ;  zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) 
     118      END WHERE 
     119      IF( iom_use('alb_ice' ) )  CALL iom_put( "alb_ice"  , zalb(:,:) )           ! ice albedo output 
     120 
     121      zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + 0.066_wp * ( 1._wp - SUM( a_i_b, dim=3 ) )       
     122      IF( iom_use('albedo'  ) )  CALL iom_put( "albedo"  , zalb(:,:) )           ! ice albedo output 
     123 
     124      CALL wrk_dealloc( jpi,jpj, zalb )     
     125      ! 
     126       
    124127      DO jj = 1, jpj 
    125128         DO ji = 1, jpi 
    … …  
    140143            hfx_out(ji,jj) = hfx_out(ji,jj) + zqmass + zqsr 
    141144 
    142             ! Add the residual from heat diffusion equation (W.m-2) 
    143             !------------------------------------------------------- 
    144             hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) 
     145            ! Add the residual from heat diffusion equation and sublimation (W.m-2) 
     146            !---------------------------------------------------------------------- 
     147            hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) +   & 
     148               &           ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 
    145149 
    146150            ! New qsr and qns used to compute the oceanic heat flux at the next time step 
    147             !--------------------------------------------------- 
     151            !---------------------------------------------------------------------------- 
    148152            qsr(ji,jj) = zqsr                                       
    149153            qns(ji,jj) = hfx_out(ji,jj) - zqsr               
    … …  
    165169 
    166170            ! mass flux at the ocean/ice interface 
    167             fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) ) * r1_rdtice  ! F/M mass flux save at least for biogeochemical model 
    168             emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
    169              
     171            fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) )              ! F/M mass flux save at least for biogeochemical model 
     172            emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
    170173         END DO 
    171174      END DO 
    … …  
    175178      !------------------------------------------! 
    176179      sfx(:,:) = sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + sfx_opw(:,:)   & 
    177          &     + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) 
     180         &     + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) + sfx_sub(:,:) 
    178181 
    179182      !-------------------------------------------------------------! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90

    r5602 r7256  
    461461 
    462462      DO ji = kideb, kiut 
    463          zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) ) 
     463         zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) + dh_i_sub(ji) ) 
    464464         IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp )  THEN 
    465465            zvi          = a_i_1d(ji) * ht_i_1d(ji) 
    … …  
    470470            zda_mel     = rswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) ) 
    471471            a_i_1d(ji)  = MAX( epsi20, a_i_1d(ji) + zda_mel )  
    472              ! adjust thickness 
     472            ! adjust thickness 
    473473            ht_i_1d(ji) = zvi / a_i_1d(ji)             
    474474            ht_s_1d(ji) = zvs / a_i_1d(ji)             
    … …  
    514514          
    515515         CALL tab_2d_1d( nbpb, qprec_ice_1d(1:nbpb), qprec_ice(:,:) , jpi, jpj, npb(1:nbpb) ) 
     516         CALL tab_2d_1d( nbpb, qevap_ice_1d(1:nbpb), qevap_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    516517         CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    517518         CALL tab_2d_1d( nbpb, fr1_i0_1d  (1:nbpb), fr1_i0          , jpi, jpj, npb(1:nbpb) ) 
    … …  
    543544         CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri         , jpi, jpj, npb(1:nbpb) ) 
    544545         CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res         , jpi, jpj, npb(1:nbpb) ) 
    545           
     546         CALL tab_2d_1d( nbpb, sfx_sub_1d (1:nbpb), sfx_sub         , jpi, jpj,npb(1:nbpb) ) 
     547  
    546548         CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd         , jpi, jpj, npb(1:nbpb) ) 
    547549         CALL tab_2d_1d( nbpb, hfx_spr_1d (1:nbpb), hfx_spr         , jpi, jpj, npb(1:nbpb) ) 
    … …  
    593595         CALL tab_1d_2d( nbpb, sfx_res       , npb, sfx_res_1d(1:nbpb)   , jpi, jpj ) 
    594596         CALL tab_1d_2d( nbpb, sfx_bri       , npb, sfx_bri_1d(1:nbpb)   , jpi, jpj ) 
    595           
     597         CALL tab_1d_2d( nbpb, sfx_sub       , npb, sfx_sub_1d(1:nbpb)   , jpi, jpj )         
     598  
    596599         CALL tab_1d_2d( nbpb, hfx_thd       , npb, hfx_thd_1d(1:nbpb)   , jpi, jpj ) 
    597600         CALL tab_1d_2d( nbpb, hfx_spr       , npb, hfx_spr_1d(1:nbpb)   , jpi, jpj ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90

    r5602 r7256  
    7474 
    7575      REAL(wp) ::   ztmelts             ! local scalar 
    76       REAL(wp) ::   zfdum        
     76      REAL(wp) ::   zdum        
    7777      REAL(wp) ::   zfracs       ! fractionation coefficient for bottom salt entrapment 
    7878      REAL(wp) ::   zs_snic      ! snow-ice salinity 
    … …  
    9595      REAL(wp), POINTER, DIMENSION(:) ::   zq_rema     ! remaining heat at the end of the routine    (J.m-2) 
    9696      REAL(wp), POINTER, DIMENSION(:) ::   zf_tt       ! Heat budget to determine melting or freezing(W.m-2) 
     97      REAL(wp), POINTER, DIMENSION(:) ::   zevap_rema  ! remaining mass flux from sublimation        (kg.m-2) 
    9798 
    9899      REAL(wp), POINTER, DIMENSION(:) ::   zdh_s_mel   ! snow melt  
    … …  
    105106 
    106107      REAL(wp), POINTER, DIMENSION(:) ::   zqh_i       ! total ice heat content  (J.m-2) 
    107       REAL(wp), POINTER, DIMENSION(:) ::   zqh_s       ! total snow heat content (J.m-2) 
    108       REAL(wp), POINTER, DIMENSION(:) ::   zq_s        ! total snow enthalpy     (J.m-3) 
    109108      REAL(wp), POINTER, DIMENSION(:) ::   zsnw        ! distribution of snow after wind blowing 
    110109 
    … …  
    117116 
    118117      ! Discriminate between varying salinity (nn_icesal=2) and prescribed cases (other values) 
    119       SELECT CASE( nn_icesal )                       ! varying salinity or not 
    120          CASE( 1, 3, 4 ) ;   zswitch_sal = 0       ! prescribed salinity profile 
    121          CASE( 2 )       ;   zswitch_sal = 1       ! varying salinity profile 
     118      SELECT CASE( nn_icesal )                  ! varying salinity or not 
     119         CASE( 1, 3 ) ;   zswitch_sal = 0       ! prescribed salinity profile 
     120         CASE( 2 )    ;   zswitch_sal = 1       ! varying salinity profile 
    122121      END SELECT 
    123122 
    124       CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw ) 
    125       CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
     123      CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 
     124      CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 
    126125      CALL wrk_alloc( jpij, nlay_i, zdeltah, zh_i ) 
    127126      CALL wrk_alloc( jpij, nlay_i, icount ) 
    128127        
    129       dh_i_surf  (:) = 0._wp ; dh_i_bott  (:) = 0._wp ; dh_snowice(:) = 0._wp 
     128      dh_i_surf  (:) = 0._wp ; dh_i_bott  (:) = 0._wp ; dh_snowice(:) = 0._wp ; dh_i_sub(:) = 0._wp 
    130129      dsm_i_se_1d(:) = 0._wp ; dsm_i_si_1d(:) = 0._wp    
    131130 
    132131      zqprec   (:) = 0._wp ; zq_su    (:) = 0._wp ; zq_bo    (:) = 0._wp ; zf_tt(:) = 0._wp 
    133       zq_rema  (:) = 0._wp ; zsnw     (:) = 0._wp 
     132      zq_rema  (:) = 0._wp ; zsnw     (:) = 0._wp ; zevap_rema(:) = 0._wp ; 
    134133      zdh_s_mel(:) = 0._wp ; zdh_s_pre(:) = 0._wp ; zdh_s_sub(:) = 0._wp ; zqh_i(:) = 0._wp 
    135       zqh_s    (:) = 0._wp ; zq_s     (:) = 0._wp      
    136134 
    137135      zdeltah(:,:) = 0._wp ; zh_i(:,:) = 0._wp        
    … …  
    159157      ! 
    160158      DO ji = kideb, kiut 
    161          zfdum      = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)  
     159         zdum       = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)  
    162160         zf_tt(ji)  = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji)  
    163161 
    164          zq_su (ji) = MAX( 0._wp, zfdum     * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 
     162         zq_su (ji) = MAX( 0._wp, zdum      * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 
    165163         zq_bo (ji) = MAX( 0._wp, zf_tt(ji) * rdt_ice ) 
    166164      END DO 
    … …  
    187185      !  2) Computing layer thicknesses and enthalpies.            ! 
    188186      !------------------------------------------------------------! 
    189       ! 
    190       DO jk = 1, nlay_s 
    191          DO ji = kideb, kiut 
    192             zqh_s(ji) =  zqh_s(ji) + q_s_1d(ji,jk) * ht_s_1d(ji) * r1_nlay_s 
    193          END DO 
    194       END DO 
    195187      ! 
    196188      DO jk = 1, nlay_i 
    … …  
    275267      END DO 
    276268 
    277       !---------------------- 
    278       ! 3.2 Snow sublimation  
    279       !---------------------- 
     269      !------------------------------ 
     270      ! 3.2 Sublimation (part1: snow)  
     271      !------------------------------ 
    280272      ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 
    281273      ! clem comment: not counted in mass/heat exchange in limsbc since this is an exchange with atm. (not ocean) 
    282       ! clem comment: ice should also sublimate 
    283274      zdeltah(:,:) = 0._wp 
    284       ! coupled mode: sublimation is set to 0 (evap_ice = 0) until further notice 
    285       ! forced  mode: snow thickness change due to sublimation 
    286       DO ji = kideb, kiut 
    287          zdh_s_sub(ji)  =  MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 
    288          ! Heat flux by sublimation [W.m-2], < 0 
    289          !      sublimate first snow that had fallen, then pre-existing snow 
     275      DO ji = kideb, kiut 
     276         zdh_s_sub(ji)  = MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 
     277         ! remaining evap in kg.m-2 (used for ice melting later on) 
     278         zevap_rema(ji)  = evap_ice_1d(ji) * rdt_ice + zdh_s_sub(ji) * rhosn 
     279         ! Heat flux by sublimation [W.m-2], < 0 (sublimate first snow that had fallen, then pre-existing snow) 
    290280         zdeltah(ji,1)  = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 
    291281         hfx_sub_1d(ji) = hfx_sub_1d(ji) + ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * q_s_1d(ji,1)  & 
    … …  
    309299      !------------------------------------------- 
    310300      ! new temp and enthalpy of the snow (remaining snow precip + remaining pre-existing snow) 
    311       zq_s(:) = 0._wp  
    312301      DO jk = 1, nlay_s 
    313302         DO ji = kideb,kiut 
    314             rswitch       = MAX(  0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 )  ) 
    315             q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) *                          & 
    316               &            ( (   zdh_s_pre(ji)             ) * zqprec(ji) +  & 
    317               &              (   ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 
    318             zq_s(ji)     =  zq_s(ji) + q_s_1d(ji,jk) 
     303            rswitch       = MAX( 0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 ) ) 
     304            q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) *           & 
     305              &            ( ( zdh_s_pre(ji)               ) * zqprec(ji) +  & 
     306              &              ( ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 
    319307         END DO 
    320308      END DO 
    … …  
    370358               zQm            = zfmdt * zEw                           ! Energy of the melt water sent to the ocean [J/m2, <0] 
    371359                
    372                ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
     360               ! Contribution to salt flux >0 (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
    373361               sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 
    374362                
    … …  
    383371                
    384372            END IF 
     373            ! ---------------------- 
     374            ! Sublimation part2: ice 
     375            ! ---------------------- 
     376            zdum      = MAX( - ( zh_i(ji,jk) + zdeltah(ji,jk) ) , - zevap_rema(ji) * r1_rhoic ) 
     377            zdeltah(ji,jk) = zdeltah(ji,jk) + zdum 
     378            dh_i_sub(ji)  = dh_i_sub(ji) + zdum 
     379            ! Salt flux > 0 (clem2016: flux is sent to the ocean for simplicity but salt should remain in the ice except if all ice is melted. 
     380            !                          It must be corrected at some point) 
     381            sfx_sub_1d(ji) = sfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * sm_i_1d(ji) * r1_rdtice 
     382            ! Heat flux [W.m-2], < 0 
     383            hfx_sub_1d(ji) = hfx_sub_1d(ji) + zdum * q_i_1d(ji,jk) * a_i_1d(ji) * r1_rdtice 
     384            ! Mass flux > 0 
     385            wfx_sub_1d(ji) =  wfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * r1_rdtice 
     386            ! update remaining mass flux 
     387            zevap_rema(ji)  = zevap_rema(ji) + zdum * rhoic 
     388             
    385389            ! record which layers have disappeared (for bottom melting)  
    386390            !    => icount=0 : no layer has vanished 
    … …  
    389393            icount(ji,jk) = NINT( rswitch ) 
    390394            zh_i(ji,jk)   = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) ) 
    391  
     395                         
    392396            ! update heat content (J.m-2) and layer thickness 
    393397            qh_i_old(ji,jk) = qh_i_old(ji,jk) + zdeltah(ji,jk) * q_i_1d(ji,jk) 
    … …  
    397401      ! update ice thickness 
    398402      DO ji = kideb, kiut 
    399          ht_i_1d(ji) =  MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) ) 
     403         ht_i_1d(ji) =  MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) + dh_i_sub(ji) ) 
     404      END DO 
     405 
     406      ! remaining "potential" evap is sent to ocean 
     407      DO ji = kideb, kiut 
     408         ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 
     409         wfx_err_sub(ii,ij) = wfx_err_sub(ii,ij) - zevap_rema(ji) * a_i_1d(ji) * r1_rdtice  ! <=0 (net evap for the ocean in kg.m-2.s-1) 
    400410      END DO 
    401411 
    … …  
    641651 
    642652         ! Contribution to energy flux to the ocean [J/m2], >0 (if sst<0) 
    643          ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 
    644653         zfmdt          = ( rhosn - rhoic ) * MAX( dh_snowice(ji), 0._wp )    ! <0 
    645654         zsstK          = sst_m(ii,ij) + rt0                                 
    … …  
    652661         ! Contribution to salt flux 
    653662         sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_m(ii,ij) * a_i_1d(ji) * zfmdt * r1_rdtice  
     663 
     664         ! virtual salt flux to keep salinity constant 
     665         IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     666            sfx_bri_1d(ji) = sfx_bri_1d(ji) - sss_m(ii,ij) * a_i_1d(ji) * zfmdt                  * r1_rdtice  & ! put back sss_m into the ocean 
     667               &                            - sm_i_1d(ji)  * a_i_1d(ji) * dh_snowice(ji) * rhoic * r1_rdtice    ! and get  sm_i  from the ocean  
     668         ENDIF 
    654669           
    655670         ! Contribution to mass flux 
    … …  
    686701      WHERE( ht_i_1d == 0._wp ) a_i_1d = 0._wp 
    687702       
    688       CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw ) 
    689       CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
     703      CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 
     704      CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 
    690705      CALL wrk_dealloc( jpij, nlay_i, zdeltah, zh_i ) 
    691706      CALL wrk_dealloc( jpij, nlay_i, icount ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90

    r5602 r7256  
    7575      INTEGER ::   ii, ij, iter     !   -       - 
    7676      REAL(wp)  ::   ztmelts, zdv, zfrazb, zweight, zde                         ! local scalars 
    77       REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf , zhicol_new        !   -      - 
     77      REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf                     !   -      - 
    7878      REAL(wp) ::   ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit   !   -      - 
    79       LOGICAL  ::   iterate_frazil   ! iterate frazil ice collection thickness 
    8079      CHARACTER (len = 15) :: fieldid 
    8180 
    … …  
    108107      REAL(wp), POINTER, DIMENSION(:,:) ::   zsmv_i_1d ! 1-D version of smv_i 
    109108 
    110       REAL(wp), POINTER, DIMENSION(:,:,:) ::   ze_i_1d   !: 1-D version of e_i 
    111  
    112       REAL(wp), POINTER, DIMENSION(:,:) ::   zvrel                   ! relative ice / frazil velocity 
    113  
    114       REAL(wp) :: zcai = 1.4e-3_wp 
     109      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ze_i_1d !: 1-D version of e_i 
     110 
     111      REAL(wp), POINTER, DIMENSION(:,:) ::   zvrel     ! relative ice / frazil velocity 
     112 
     113      REAL(wp) :: zcai = 1.4e-3_wp                     ! ice-air drag (clem: should be dependent on coupling/forcing used) 
    115114      !!-----------------------------------------------------------------------! 
    116115 
    … …  
    143142      !------------------------------------------------------------------------------!     
    144143      ! hicol is the thickness of new ice formed in open water 
    145       ! hicol can be either prescribed (frazswi = 0) 
    146       ! or computed (frazswi = 1) 
     144      ! hicol can be either prescribed (frazswi = 0) or computed (frazswi = 1) 
    147145      ! Frazil ice forms in open water, is transported by wind 
    148146      ! accumulates at the edge of the consolidated ice edge 
    … …  
    155153      zvrel(:,:) = 0._wp 
    156154 
    157       ! Default new ice thickness  
    158       hicol(:,:) = rn_hnewice 
     155      ! Default new ice thickness 
     156      WHERE( qlead(:,:) < 0._wp ) ; hicol = rn_hnewice 
     157      ELSEWHERE                   ; hicol = 0._wp 
     158      END WHERE 
    159159 
    160160      IF( ln_frazil ) THEN 
    … …  
    182182                     &          +   vtau_ice(ji  ,jj  ) * vmask(ji  ,jj  ,1) ) * 0.5_wp 
    183183                  ! Square root of wind stress 
    184                   ztenagm       =  SQRT( SQRT( ztaux**2 + ztauy**2 ) ) 
     184                  ztenagm       =  SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 
    185185 
    186186                  !--------------------- 
    … …  
    205205                  zvrel2 = MAX(  ( zvfrx - zvgx ) * ( zvfrx - zvgx )   & 
    206206                     &         + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) 
    207                   zvrel(ji,jj)  = SQRT( zvrel2 ) 
     207                  zvrel(ji,jj) = SQRT( zvrel2 ) 
    208208 
    209209                  !--------------------- 
    210210                  ! Iterative procedure 
    211211                  !--------------------- 
    212                   hicol(ji,jj) = zhicrit + 0.1  
    213                   hicol(ji,jj) = zhicrit +   hicol(ji,jj)    & 
    214                      &                   / ( hicol(ji,jj) * hicol(ji,jj) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
    215  
    216 !!gm better coding: above: hicol(ji,jj) * hicol(ji,jj) = (zhicrit + 0.1)*(zhicrit + 0.1) 
    217 !!gm                                                   = zhicrit**2 + 0.2*zhicrit +0.01 
    218 !!gm                therefore the 2 lines with hicol can be replaced by 1 line: 
    219 !!gm              hicol(ji,jj) = zhicrit + (zhicrit + 0.1) / ( 0.2 * zhicrit + 0.01 ) * ztwogp * zvrel2 
    220 !!gm further more (zhicrit + 0.1)/(0.2 * zhicrit + 0.01 )*ztwogp can be computed one for all outside the DO loop 
     212                  hicol(ji,jj) = zhicrit +   ( zhicrit + 0.1 )    & 
     213                     &                   / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
    221214 
    222215                  iter = 1 
    223                   iterate_frazil = .true. 
    224  
    225                   DO WHILE ( iter < 100 .AND. iterate_frazil )  
    226                      zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) & 
    227                         - hicol(ji,jj) * zhicrit * ztwogp * zvrel2 
    228                      zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0*hicol(ji,jj) + zhicrit ) & 
    229                         - zhicrit * ztwogp * zvrel2 
    230                      zhicol_new = hicol(ji,jj) - zf/zfp 
    231                      hicol(ji,jj)   = zhicol_new 
    232  
     216                  DO WHILE ( iter < 20 )  
     217                     zf  = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj) * hicol(ji,jj) - zhicrit * zhicrit ) -   & 
     218                        &    hicol(ji,jj) * zhicrit * ztwogp * zvrel2 
     219                     zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0 * hicol(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 
     220 
     221                     hicol(ji,jj) = hicol(ji,jj) - zf/zfp 
    233222                     iter = iter + 1 
    234  
    235                   END DO ! do while 
     223                  END DO 
    236224 
    237225               ENDIF ! end of selection of pixels where ice forms 
    238226 
    239             END DO ! loop on ji ends 
    240          END DO ! loop on jj ends 
    241       !  
    242       CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 
    243       CALL lbc_lnk( hicol(:,:), 'T', 1. ) 
     227            END DO  
     228         END DO  
     229         !  
     230         CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 
     231         CALL lbc_lnk( hicol(:,:), 'T', 1. ) 
    244232 
    245233      ENDIF ! End of computation of frazil ice collection thickness 
    … …  
    282270      ! Move from 2-D to 1-D vectors 
    283271      !------------------------------ 
    284       ! If ocean gains heat do nothing  
    285       ! 0therwise compute new ice formation 
     272      ! If ocean gains heat do nothing. Otherwise compute new ice formation 
    286273 
    287274      IF ( nbpac > 0 ) THEN 
    … …  
    297284         END DO 
    298285 
    299          CALL tab_2d_1d( nbpac, qlead_1d  (1:nbpac)     , qlead  , jpi, jpj, npac(1:nbpac) ) 
    300          CALL tab_2d_1d( nbpac, t_bo_1d   (1:nbpac)     , t_bo   , jpi, jpj, npac(1:nbpac) ) 
    301          CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac)     , sfx_opw, jpi, jpj, npac(1:nbpac) ) 
    302          CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac)     , wfx_opw, jpi, jpj, npac(1:nbpac) ) 
    303          CALL tab_2d_1d( nbpac, hicol_1d  (1:nbpac)     , hicol  , jpi, jpj, npac(1:nbpac) ) 
    304          CALL tab_2d_1d( nbpac, zvrel_1d  (1:nbpac)     , zvrel  , jpi, jpj, npac(1:nbpac) ) 
    305  
    306          CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac)     , hfx_thd, jpi, jpj, npac(1:nbpac) ) 
    307          CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac)     , hfx_opw, jpi, jpj, npac(1:nbpac) ) 
     286         CALL tab_2d_1d( nbpac, qlead_1d  (1:nbpac)     , qlead     , jpi, jpj, npac(1:nbpac) ) 
     287         CALL tab_2d_1d( nbpac, t_bo_1d   (1:nbpac)     , t_bo      , jpi, jpj, npac(1:nbpac) ) 
     288         CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac)     , sfx_opw   , jpi, jpj, npac(1:nbpac) ) 
     289         CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac)     , wfx_opw   , jpi, jpj, npac(1:nbpac) ) 
     290         CALL tab_2d_1d( nbpac, hicol_1d  (1:nbpac)     , hicol     , jpi, jpj, npac(1:nbpac) ) 
     291         CALL tab_2d_1d( nbpac, zvrel_1d  (1:nbpac)     , zvrel     , jpi, jpj, npac(1:nbpac) ) 
     292 
     293         CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac)     , hfx_thd   , jpi, jpj, npac(1:nbpac) ) 
     294         CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac)     , hfx_opw   , jpi, jpj, npac(1:nbpac) ) 
     295         CALL tab_2d_1d( nbpac, rn_amax_1d(1:nbpac)     , rn_amax_2d, jpi, jpj, npac(1:nbpac) ) 
    308296 
    309297         !------------------------------------------------------------------------------! 
    … …  
    316304         zv_b(1:nbpac,:) = zv_i_1d(1:nbpac,:)  
    317305         za_b(1:nbpac,:) = za_i_1d(1:nbpac,:) 
     306 
    318307         !---------------------- 
    319308         ! Thickness of new ice 
    320309         !---------------------- 
    321          DO ji = 1, nbpac 
    322             zh_newice(ji) = rn_hnewice 
    323          END DO 
    324          IF( ln_frazil ) zh_newice(1:nbpac) = hicol_1d(1:nbpac) 
     310         zh_newice(1:nbpac) = hicol_1d(1:nbpac) 
    325311 
    326312         !---------------------- 
    … …  
    384370            ! salt flux 
    385371            sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoic * zs_newice(ji) * r1_rdtice 
    386  
     372         END DO 
     373          
     374         zv_frazb(:) = 0._wp 
     375         IF( ln_frazil ) THEN 
    387376            ! A fraction zfrazb of frazil ice is accreted at the ice bottom 
    388             rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 
    389             zfrazb        = rswitch * ( TANH ( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 
    390             zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
    391             zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 
    392          END DO 
    393  
     377            DO ji = 1, nbpac 
     378               rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 
     379               zfrazb        = rswitch * ( TANH( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 
     380               zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
     381               zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 
     382            END DO 
     383         END IF 
     384          
    394385         !----------------- 
    395386         ! Area of new ice 
    … …  
    409400         ! we keep the excessive volume in memory and attribute it later to bottom accretion 
    410401         DO ji = 1, nbpac 
    411             IF ( za_newice(ji) >  ( rn_amax - zat_i_1d(ji) ) ) THEN 
    412                zda_res(ji)   = za_newice(ji) - ( rn_amax - zat_i_1d(ji) ) 
     402            IF ( za_newice(ji) >  ( rn_amax_1d(ji) - zat_i_1d(ji) ) ) THEN 
     403               zda_res(ji)   = za_newice(ji) - ( rn_amax_1d(ji) - zat_i_1d(ji) ) 
    413404               zdv_res(ji)   = zda_res  (ji) * zh_newice(ji)  
    414405               za_newice(ji) = za_newice(ji) - zda_res  (ji) 
    … …  
    443434               jl = jcat(ji) 
    444435               rswitch = MAX( 0._wp, SIGN( 1._wp , zv_i_1d(ji,jl) - epsi20 ) ) 
    445                ze_i_1d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                      & 
     436               ze_i_1d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                    & 
    446437                  &        ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_1d(ji,jk,jl) * zv_b(ji,jl) )  & 
    447438                  &        * rswitch / MAX( zv_i_1d(ji,jl), epsi20 ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90

    r5602 r7256  
    6262      END DO 
    6363  
    64       !------------------------------------------------------------------------------| 
    65       ! 1) Constant salinity, constant in time                                       | 
    66       !------------------------------------------------------------------------------| 
    67 !!gm comment: if nn_icesal = 1 s_i_new, s_i_1d and sm_i_1d can be set to rn_icesal one for all in the initialisation phase !! 
    68 !!gm           ===>>>   simplification of almost all test on nn_icesal value 
    69       IF(  nn_icesal == 1  ) THEN 
    70             s_i_1d (kideb:kiut,1:nlay_i) =  rn_icesal 
    71             sm_i_1d(kideb:kiut)          =  rn_icesal  
    72             s_i_new(kideb:kiut)          =  rn_icesal 
    73       ENDIF 
     64      !--------------------------------------------------------------------| 
     65      ! 1) salinity constant in time                                       | 
     66      !--------------------------------------------------------------------| 
     67      ! do nothing 
    7468 
    75       !------------------------------------------------------------------------------| 
    76       !  Module 2 : Constant salinity varying in time                                | 
    77       !------------------------------------------------------------------------------| 
     69      !----------------------------------------------------------------------| 
     70      !  2) salinity varying in time                                         | 
     71      !----------------------------------------------------------------------| 
    7872      IF(  nn_icesal == 2  ) THEN 
    7973 
    … …  
    113107 
    114108      !------------------------------------------------------------------------------| 
    115       !  Module 3 : Profile of salinity, constant in time                            | 
     109      !  3) vertical profile of salinity, constant in time                           | 
    116110      !------------------------------------------------------------------------------| 
    117111      IF(  nn_icesal == 3  )   CALL lim_var_salprof1d( kideb, kiut ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90

    r5602 r7256  
    6363      INTEGER, INTENT(in) ::   kt           ! number of iteration 
    6464      ! 
    65       INTEGER  ::   ji, jj, jk, jl, jt      ! dummy loop indices 
     65      INTEGER  ::   ji, jj, jk, jm , jl, jt      ! dummy loop indices 
    6666      INTEGER  ::   initad                  ! number of sub-timestep for the advection 
    6767      REAL(wp) ::   zcfl , zusnit           !   -      - 
    … …  
    7575      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   zhimax                   ! old ice thickness 
    7676      REAL(wp), POINTER, DIMENSION(:,:)      ::   zatold, zeiold, zesold   ! old concentration, enthalpies 
     77      REAL(wp), POINTER, DIMENSION(:,:,:)             ::   zhdfptab 
    7778      REAL(wp) ::    zdv, zvi, zvs, zsmv, zes, zei 
    7879      REAL(wp) ::    zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 
     80      !!--------------------------------------------------------------------- 
     81      INTEGER                                ::  ihdf_vars  = 6  !!Number of variables in which we apply horizontal diffusion 
     82                                                                   !!  inside limtrp for each ice category , not counting the  
     83                                                                   !!  variables corresponding to ice_layers  
    7984      !!--------------------------------------------------------------------- 
    8085      IF( nn_timing == 1 )  CALL timing_start('limtrp') 
    … …  
    8590      CALL wrk_alloc( jpi,jpj,nlay_i,jpl, z0ei ) 
    8691      CALL wrk_alloc( jpi,jpj,jpl,        zhimax, zviold, zvsold, zsmvold ) 
     92      CALL wrk_alloc( jpi,jpj,jpl*(ihdf_vars + nlay_i)+1,zhdfptab) 
    8793 
    8894      IF( numit == nstart .AND. lwp ) THEN 
    … …  
    170176            z0oi (:,:,jl)   = oa_i (:,:,jl) * e12t(:,:)    ! Age content 
    171177            z0es (:,:,jl)   = e_s  (:,:,1,jl) * e12t(:,:)  ! Snow heat content 
    172             DO jk = 1, nlay_i 
     178           DO jk = 1, nlay_i 
    173179               z0ei  (:,:,jk,jl) = e_i  (:,:,jk,jl) * e12t(:,:) ! Ice  heat content 
    174180            END DO 
    … …  
    284290         ! Diffusion of Ice fields                   
    285291         !------------------------------------------------------------------------------! 
    286  
     292         !------------------------------------ 
     293         !  Diffusion of other ice variables 
     294         !------------------------------------ 
     295         jm=1 
     296         DO jl = 1, jpl 
     297         !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
     298         !   DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
     299         !      DO ji = 1 , fs_jpim1   ! vector opt. 
     300         !         pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji  ,jj,jl) ) ) )   & 
     301         !            &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 
     302         !         pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj  ,jl) ) ) )   & 
     303         !            &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 
     304         !      END DO 
     305         !   END DO 
     306            DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
     307               DO ji = 1 , fs_jpim1   ! vector opt. 
     308                  pahu3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji  ,jj,  jl ) ) ) )   & 
     309                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,  jl ) ) ) ) * ahiu(ji,jj) 
     310                  pahv3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,  jj,  jl ) ) ) )   & 
     311                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,  jj+1,jl ) ) ) ) * ahiv(ji,jj) 
     312               END DO 
     313            END DO 
     314 
     315            zhdfptab(:,:,jm)= a_i  (:,:,  jl); jm = jm + 1     
     316            zhdfptab(:,:,jm)= v_i  (:,:,  jl); jm = jm + 1 
     317            zhdfptab(:,:,jm)= v_s  (:,:,  jl); jm = jm + 1  
     318            zhdfptab(:,:,jm)= smv_i(:,:,  jl); jm = jm + 1 
     319            zhdfptab(:,:,jm)= oa_i (:,:,  jl); jm = jm + 1 
     320            zhdfptab(:,:,jm)= e_s  (:,:,1,jl); jm = jm + 1 
     321         ! Sample of adding more variables to apply lim_hdf using lim_hdf optimization--- 
     322         !   zhdfptab(:,:,jm) = variable_1 (:,:,1,jl); jm = jm + 1   
     323         !   zhdfptab(:,:,jm) = variable_2 (:,:,1,jl); jm = jm + 1  
     324         ! 
     325         ! and in this example the parameter ihdf_vars musb be changed to 8 (necessary for allocation) 
     326         !---------------------------------------------------------------------------------------- 
     327            DO jk = 1, nlay_i 
     328              zhdfptab(:,:,jm)=e_i(:,:,jk,jl); jm= jm+1 
     329            END DO 
     330         END DO 
    287331         ! 
    288332         !-------------------------------- 
    … …  
    290334         !-------------------------------- 
    291335         !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
     336         !DO jj = 1, jpjm1                    ! NB: has not to be defined on jpj line and jpi row 
     337         !   DO ji = 1 , fs_jpim1   ! vector opt. 
     338         !      pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji  ,jj) ) ) )   & 
     339         !         &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 
     340         !      pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj  ) ) ) )   & 
     341         !         &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 
     342         !   END DO 
     343         !END DO 
     344          
    292345         DO jj = 1, jpjm1                    ! NB: has not to be defined on jpj line and jpi row 
    293346            DO ji = 1 , fs_jpim1   ! vector opt. 
    294                pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji  ,jj) ) ) )   & 
    295                   &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 
    296                pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj  ) ) ) )   & 
    297                   &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 
     347               pahu3D(ji,jj,jpl+1) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji  ,jj) ) ) )   & 
     348                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 
     349               pahv3D(ji,jj,jpl+1) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj  ) ) ) )   & 
     350                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 
    298351            END DO 
    299352         END DO 
    300353         ! 
    301          CALL lim_hdf( ato_i (:,:) ) 
    302  
    303          !------------------------------------ 
    304          !  Diffusion of other ice variables 
    305          !------------------------------------ 
    306          DO jl = 1, jpl 
    307          !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
    308             DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
    309                DO ji = 1 , fs_jpim1   ! vector opt. 
    310                   pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji  ,jj,jl) ) ) )   & 
    311                      &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 
    312                   pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj  ,jl) ) ) )   & 
    313                      &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 
    314                END DO 
    315             END DO 
    316  
    317             CALL lim_hdf( v_i  (:,:,  jl) ) 
    318             CALL lim_hdf( v_s  (:,:,  jl) ) 
    319             CALL lim_hdf( smv_i(:,:,  jl) ) 
    320             CALL lim_hdf( oa_i (:,:,  jl) ) 
    321             CALL lim_hdf( a_i  (:,:,  jl) ) 
    322             CALL lim_hdf( e_s  (:,:,1,jl) ) 
     354         zhdfptab(:,:,jm)= ato_i  (:,:); 
     355         CALL lim_hdf( zhdfptab, ihdf_vars, jpl, nlay_i)  
     356 
     357         jm=1 
     358         DO jl = 1, jpl 
     359            a_i  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1       
     360            v_i  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     361            v_s  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     362            smv_i(:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     363            oa_i (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     364            e_s  (:,:,1,jl) = zhdfptab(:,:,jm); jm = jm + 1  
     365         ! Sample of adding more variables to apply lim_hdf--------- 
     366         !   variable_1  (:,:,1,jl) = zhdfptab(:,:, jm  ) ; jm + 1  
     367         !   variable_2  (:,:,1,jl) = zhdfptab(:,:, jm  ) ; jm + 1 
     368         !----------------------------------------------------------- 
    323369            DO jk = 1, nlay_i 
    324                CALL lim_hdf( e_i(:,:,jk,jl) ) 
    325             END DO 
    326          END DO 
     370               e_i(:,:,jk,jl) = zhdfptab(:,:,jm);jm= jm + 1  
     371            END DO 
     372         END DO 
     373 
     374         ato_i  (:,:) = zhdfptab(:,:,jm) 
    327375 
    328376         !------------------------------------------------------------------------------! 
    … …  
    422470            DO jj = 1, jpj 
    423471               DO ji = 1, jpi 
    424                   a_i(ji,jj,1)  = MIN( a_i(ji,jj,1), rn_amax ) 
     472                  a_i(ji,jj,1)  = MIN( a_i(ji,jj,1), rn_amax_2d(ji,jj) ) 
    425473               END DO 
    426474            END DO 
    … …  
    464512      CALL wrk_dealloc( jpi,jpj,nlay_i,jpl, z0ei ) 
    465513      CALL wrk_dealloc( jpi,jpj,jpl,        zviold, zvsold, zhimax, zsmvold ) 
     514      CALL wrk_dealloc( jpi,jpj,jpl*(ihdf_vars+nlay_i)+1,zhdfptab) 
    466515      ! 
    467516      IF( nn_timing == 1 )  CALL timing_stop('limtrp') 
    … …  
    479528   !!====================================================================== 
    480529END MODULE limtrp 
     530 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limupdate1.F90

    r5602 r7256  
    8080         DO jj = 1, jpj 
    8181            DO ji = 1, jpi 
    82                IF( at_i(ji,jj) > rn_amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
    83                   a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
    84                   oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
     82               IF( at_i(ji,jj) > rn_amax_2d(ji,jj) .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
     83                  a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 
     84                  oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 
    8585               ENDIF 
    8686            END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limupdate2.F90

    r5602 r7256  
    9494         DO jj = 1, jpj 
    9595            DO ji = 1, jpi 
    96                IF( at_i(ji,jj) > rn_amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
    97                   a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
    98                   oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
     96               IF( at_i(ji,jj) > rn_amax_2d(ji,jj) .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
     97                  a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 
     98                  oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 
    9999               ENDIF 
    100100            END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90

    r5602 r7256  
    5454   PUBLIC   lim_var_eqv2glo       
    5555   PUBLIC   lim_var_salprof       
    56    PUBLIC   lim_var_icetm         
    5756   PUBLIC   lim_var_bv            
    5857   PUBLIC   lim_var_salprof1d     
    … …  
    8988      ! Compute variables 
    9089      !-------------------- 
    91       vt_i (:,:) = 0._wp 
    92       vt_s (:,:) = 0._wp 
    93       at_i (:,:) = 0._wp 
    94       ato_i(:,:) = 1._wp 
    95       ! 
    96       DO jl = 1, jpl 
    97          DO jj = 1, jpj 
    98             DO ji = 1, jpi 
    99                ! 
    100                vt_i(ji,jj) = vt_i(ji,jj) + v_i(ji,jj,jl) ! ice volume 
    101                vt_s(ji,jj) = vt_s(ji,jj) + v_s(ji,jj,jl) ! snow volume 
    102                at_i(ji,jj) = at_i(ji,jj) + a_i(ji,jj,jl) ! ice concentration 
    103                ! 
    104                rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) )  
    105                icethi(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj) , epsi10 ) * rswitch  ! ice thickness 
    106             END DO 
    107          END DO 
    108       END DO 
    109  
     90      ! integrated values 
     91      vt_i (:,:) = SUM( v_i, dim=3 ) 
     92      vt_s (:,:) = SUM( v_s, dim=3 ) 
     93      at_i (:,:) = SUM( a_i, dim=3 ) 
     94      et_s(:,:)  = SUM( SUM( e_s(:,:,:,:), dim=4 ), dim=3 ) 
     95      et_i(:,:)  = SUM( SUM( e_i(:,:,:,:), dim=4 ), dim=3 ) 
     96      ! 
    11097      DO jj = 1, jpj 
    11198         DO ji = 1, jpi 
    … …  
    115102 
    116103      IF( kn > 1 ) THEN 
    117          et_s (:,:) = 0._wp 
    118          ot_i (:,:) = 0._wp 
     104         ! 
     105         ! mean ice/snow thickness 
     106         DO jj = 1, jpj 
     107            DO ji = 1, jpi 
     108               rswitch      = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) )  
     109               htm_i(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj) , epsi10 ) * rswitch 
     110               htm_s(ji,jj) = vt_s(ji,jj) / MAX( at_i(ji,jj) , epsi10 ) * rswitch 
     111            ENDDO 
     112         ENDDO 
     113 
     114         ! mean temperature (K), salinity and age 
    119115         smt_i(:,:) = 0._wp 
    120          et_i (:,:) = 0._wp 
    121          ! 
     116         tm_i(:,:)  = 0._wp 
     117         tm_su(:,:) = 0._wp 
     118         om_i (:,:) = 0._wp 
    122119         DO jl = 1, jpl 
     120             
    123121            DO jj = 1, jpj 
    124122               DO ji = 1, jpi 
    125                   et_s(ji,jj)  = et_s(ji,jj)  + e_s(ji,jj,1,jl)                                           ! snow heat content 
    126                   rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi20 ) )  
    127                   smt_i(ji,jj) = smt_i(ji,jj) + smv_i(ji,jj,jl) / MAX( vt_i(ji,jj) , epsi20 ) * rswitch   ! ice salinity 
    128                   rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi20 ) )  
    129                   ot_i(ji,jj)  = ot_i(ji,jj)  + oa_i(ji,jj,jl)  / MAX( at_i(ji,jj) , epsi20 ) * rswitch   ! ice age 
    130                END DO 
    131             END DO 
    132          END DO 
    133          ! 
    134          DO jl = 1, jpl 
     123                  rswitch      = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) 
     124                  tm_su(ji,jj) = tm_su(ji,jj) + rswitch * ( t_su(ji,jj,jl) - rt0 ) * a_i(ji,jj,jl) / MAX( at_i(ji,jj) , epsi10 ) 
     125                  om_i (ji,jj) = om_i (ji,jj) + rswitch *   oa_i(ji,jj,jl)                         / MAX( at_i(ji,jj) , epsi10 ) 
     126               END DO 
     127            END DO 
     128             
    135129            DO jk = 1, nlay_i 
    136                et_i(:,:) = et_i(:,:) + e_i(:,:,jk,jl)       ! ice heat content 
    137             END DO 
    138          END DO 
     130               DO jj = 1, jpj 
     131                  DO ji = 1, jpi 
     132                     rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi10 ) ) 
     133                     tm_i(ji,jj)  = tm_i(ji,jj)  + r1_nlay_i * rswitch * ( t_i(ji,jj,jk,jl) - rt0 ) * v_i(ji,jj,jl)  & 
     134                        &            / MAX( vt_i(ji,jj) , epsi10 ) 
     135                     smt_i(ji,jj) = smt_i(ji,jj) + r1_nlay_i * rswitch * s_i(ji,jj,jk,jl) * v_i(ji,jj,jl)  & 
     136                        &            / MAX( vt_i(ji,jj) , epsi10 ) 
     137                  END DO 
     138               END DO 
     139            END DO 
     140         END DO 
     141         tm_i  = tm_i  + rt0 
     142         tm_su = tm_su + rt0 
    139143         ! 
    140144      ENDIF 
    … …  
    163167               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
    164168               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     169            END DO 
     170         END DO 
     171      END DO 
     172      ! Force the upper limit of ht_i to always be < hi_max (99 m). 
     173      DO jj = 1, jpj 
     174         DO ji = 1, jpi 
     175            rswitch = MAX( 0._wp , SIGN( 1._wp, ht_i(ji,jj,jpl) - epsi20 ) ) 
     176            ht_i(ji,jj,jpl) = MIN( ht_i(ji,jj,jpl) , hi_max(jpl) ) 
     177            a_i (ji,jj,jpl) = v_i(ji,jj,jpl) / MAX( ht_i(ji,jj,jpl) , epsi20 ) * rswitch 
     178         END DO 
     179      END DO 
     180 
     181      DO jl = 1, jpl 
     182         DO jj = 1, jpj 
     183            DO ji = 1, jpi 
     184               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
    165185               ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    166186               o_i(ji,jj,jl)  = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    … …  
    168188         END DO 
    169189      END DO 
    170  
     190       
    171191      IF(  nn_icesal == 2  )THEN 
    172192         DO jl = 1, jpl 
    … …  
    230250      ! Mean temperature 
    231251      !------------------- 
    232       vt_i (:,:) = 0._wp 
    233       DO jl = 1, jpl 
    234          vt_i(:,:) = vt_i(:,:) + v_i(:,:,jl) 
    235       END DO 
     252      ! integrated values 
     253      vt_i (:,:) = SUM( v_i, dim=3 ) 
     254      vt_s (:,:) = SUM( v_s, dim=3 ) 
     255      at_i (:,:) = SUM( a_i, dim=3 ) 
    236256 
    237257      tm_i(:,:) = 0._wp 
    … …  
    298318      ! Vertically constant, constant in time 
    299319      !--------------------------------------- 
    300       IF(  nn_icesal == 1  )   s_i(:,:,:,:) = rn_icesal 
     320      IF(  nn_icesal == 1  )  THEN 
     321         s_i (:,:,:,:) = rn_icesal 
     322         sm_i(:,:,:)   = rn_icesal 
     323      ENDIF 
    301324 
    302325      !----------------------------------- 
    … …  
    378401   END SUBROUTINE lim_var_salprof 
    379402 
    380  
    381    SUBROUTINE lim_var_icetm 
    382       !!------------------------------------------------------------------ 
    383       !!                ***  ROUTINE lim_var_icetm *** 
    384       !! 
    385       !! ** Purpose :   computes mean sea ice temperature 
     403   SUBROUTINE lim_var_bv 
     404      !!------------------------------------------------------------------ 
     405      !!                ***  ROUTINE lim_var_bv *** 
     406      !! 
     407      !! ** Purpose :   computes mean brine volume (%) in sea ice 
     408      !! 
     409      !! ** Method  : e = - 0.054 * S (ppt) / T (C) 
     410      !! 
     411      !! References : Vancoppenolle et al., JGR, 2007 
    386412      !!------------------------------------------------------------------ 
    387413      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    388414      !!------------------------------------------------------------------ 
    389  
    390       ! Mean sea ice temperature 
    391       vt_i (:,:) = 0._wp 
    392       DO jl = 1, jpl 
    393          vt_i(:,:) = vt_i(:,:) + v_i(:,:,jl) 
    394       END DO 
    395  
    396       tm_i(:,:) = 0._wp 
     415      ! 
     416      bvm_i(:,:)   = 0._wp 
     417      bv_i (:,:,:) = 0._wp 
    397418      DO jl = 1, jpl 
    398419         DO jk = 1, nlay_i 
    399420            DO jj = 1, jpj 
    400421               DO ji = 1, jpi 
    401                   rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi10 ) ) 
    402                   tm_i(ji,jj) = tm_i(ji,jj) + r1_nlay_i * rswitch * ( t_i(ji,jj,jk,jl) - rt0 ) * v_i(ji,jj,jl)  & 
    403                      &            / MAX( vt_i(ji,jj) , epsi10 ) 
    404                END DO 
    405             END DO 
    406          END DO 
    407       END DO 
    408       tm_i = tm_i + rt0 
    409  
    410    END SUBROUTINE lim_var_icetm 
    411  
    412  
    413    SUBROUTINE lim_var_bv 
    414       !!------------------------------------------------------------------ 
    415       !!                ***  ROUTINE lim_var_bv *** 
    416       !! 
    417       !! ** Purpose :   computes mean brine volume (%) in sea ice 
    418       !! 
    419       !! ** Method  : e = - 0.054 * S (ppt) / T (C) 
    420       !! 
    421       !! References : Vancoppenolle et al., JGR, 2007 
    422       !!------------------------------------------------------------------ 
    423       INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    424       REAL(wp) ::   zbvi             ! local scalars 
    425       !!------------------------------------------------------------------ 
    426       ! 
    427       vt_i (:,:) = 0._wp 
    428       DO jl = 1, jpl 
    429          vt_i(:,:) = vt_i(:,:) + v_i(:,:,jl) 
    430       END DO 
    431  
    432       bv_i(:,:) = 0._wp 
    433       DO jl = 1, jpl 
    434          DO jk = 1, nlay_i 
    435             DO jj = 1, jpj 
    436                DO ji = 1, jpi 
    437                   rswitch = (  1._wp - MAX( 0._wp , SIGN( 1._wp , (t_i(ji,jj,jk,jl) - rt0) + epsi10 ) )  ) 
    438                   zbvi  = - rswitch * tmut * s_i(ji,jj,jk,jl) / MIN( t_i(ji,jj,jk,jl) - rt0, - epsi10 )   & 
    439                      &                   * v_i(ji,jj,jl) * r1_nlay_i 
    440                   rswitch = (  1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi20 ) )  ) 
    441                   bv_i(ji,jj) = bv_i(ji,jj) + rswitch * zbvi  / MAX( vt_i(ji,jj) , epsi20 ) 
    442                END DO 
     422                  rswitch        = ( 1._wp - MAX( 0._wp , SIGN( 1._wp , (t_i(ji,jj,jk,jl) - rt0) + epsi10 ) )  ) 
     423                  bv_i(ji,jj,jl) = bv_i(ji,jj,jl) - rswitch * tmut * s_i(ji,jj,jk,jl) * r1_nlay_i  & 
     424                     &                            / MIN( t_i(ji,jj,jk,jl) - rt0, - epsi10 ) 
     425               END DO 
     426            END DO 
     427         END DO 
     428          
     429         DO jj = 1, jpj 
     430            DO ji = 1, jpi 
     431               rswitch      = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi10 ) ) 
     432               bvm_i(ji,jj) = bvm_i(ji,jj) + rswitch * bv_i(ji,jj,jl) * v_i(ji,jj,jl) / MAX( vt_i(ji,jj), epsi10 ) 
    443433            END DO 
    444434         END DO 
    … …  
    696686            zht_i(ji,1:jpl) = 0._wp 
    697687            za_i (ji,1:jpl) = 0._wp 
    698              
     688            itest(:)        = 0       
     689       
    699690            ! *** case very thin ice: fill only category 1 
    700691            IF ( i_fill == 1 ) THEN 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90

    r5602 r7256  
    1717   USE sbc_oce         ! Surface boundary condition: ocean fields 
    1818   USE sbc_ice         ! Surface boundary condition: ice fields 
    19    USE dom_ice 
    2019   USE ice 
    2120   USE limvar 
    … …  
    4039   !!---------------------------------------------------------------------- 
    4140CONTAINS 
    42  
    43 #if defined key_dimgout 
    44 # include "limwri_dimg.h90" 
    45 #else 
    4641 
    4742   SUBROUTINE lim_wri( kindic ) 
    … …  
    5954      INTEGER  ::  ji, jj, jk, jl  ! dummy loop indices 
    6055      REAL(wp) ::  z1_365 
    61       REAL(wp) ::  ztmp 
    62       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zoi, zei, zt_i, zt_s 
    63       REAL(wp), POINTER, DIMENSION(:,:)   ::  z2d, z2da, z2db, zswi    ! 2D workspace 
     56      REAL(wp) ::  z2da, z2db, ztmp 
     57      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zswi2 
     58      REAL(wp), POINTER, DIMENSION(:,:)   ::  z2d, zswi    ! 2D workspace 
    6459      !!------------------------------------------------------------------- 
    6560 
    6661      IF( nn_timing == 1 )  CALL timing_start('limwri') 
    6762 
    68       CALL wrk_alloc( jpi, jpj, jpl, zoi, zei, zt_i, zt_s ) 
    69       CALL wrk_alloc( jpi, jpj     , z2d, z2da, z2db, zswi ) 
     63      CALL wrk_alloc( jpi, jpj, jpl, zswi2 ) 
     64      CALL wrk_alloc( jpi, jpj     , z2d, zswi ) 
    7065 
    7166      !----------------------------- 
    … …  
    7469      z1_365 = 1._wp / 365._wp 
    7570 
    76       CALL lim_var_icetm      ! mean sea ice temperature 
    77  
    78       CALL lim_var_bv         ! brine volume 
    79  
    80       DO jj = 1, jpj          ! presence indicator of ice 
     71      ! brine volume 
     72      CALL lim_var_bv  
     73 
     74      ! tresholds for outputs 
     75      DO jj = 1, jpj 
    8176         DO ji = 1, jpi 
    8277            zswi(ji,jj)  = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) 
    8378         END DO 
    8479      END DO 
    85       ! 
    86       ! 
    87       !                                              
    88       IF ( iom_use( "icethic_cea" ) ) THEN                       ! mean ice thickness 
    89          DO jj = 1, jpj  
     80      DO jl = 1, jpl 
     81         DO jj = 1, jpj 
    9082            DO ji = 1, jpi 
    91                z2d(ji,jj)  = vt_i(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zswi(ji,jj) 
     83               zswi2(ji,jj,jl)  = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 
    9284            END DO 
    9385         END DO 
    94          CALL iom_put( "icethic_cea"  , z2d              ) 
    95       ENDIF 
    96  
    97       IF ( iom_use( "snowthic_cea" ) ) THEN                      ! snow thickness = mean snow thickness over the cell  
    98          DO jj = 1, jpj                                             
    99             DO ji = 1, jpi 
    100                z2d(ji,jj)  = vt_s(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zswi(ji,jj) 
    101             END DO 
    102          END DO 
    103          CALL iom_put( "snowthic_cea" , z2d              )        
    104       ENDIF 
     86      END DO 
    10587      ! 
     88      ! fluxes  
     89      ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 
     90      IF( iom_use('qsr_oce') )   CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) )                                   !     solar flux at ocean surface 
     91      IF( iom_use('qns_oce') )   CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) )                   ! non-solar flux at ocean surface 
     92      IF( iom_use('qsr_ice') )   CALL iom_put( "qsr_ice" , SUM( qsr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) )                 !     solar flux at ice surface 
     93      IF( iom_use('qns_ice') )   CALL iom_put( "qns_ice" , SUM( qns_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) ! non-solar flux at ice surface 
     94      IF( iom_use('qtr_ice') )   CALL iom_put( "qtr_ice" , SUM( ftr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) )                 !     solar flux transmitted thru ice 
     95      IF( iom_use('qt_oce' ) )   CALL iom_put( "qt_oce"  , ( qsr_oce(:,:) + qns_oce(:,:) ) * pfrld(:,:) + qemp_oce(:,:) )   
     96      IF( iom_use('qt_ice' ) )   CALL iom_put( "qt_ice"  , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) )   & 
     97         &                                                      * a_i_b(:,:,:),dim=3 ) + qemp_ice(:,:) ) 
     98      IF( iom_use('qemp_oce') )  CALL iom_put( "qemp_oce" , qemp_oce(:,:) )   
     99      IF( iom_use('qemp_ice') )  CALL iom_put( "qemp_ice" , qemp_ice(:,:) )   
     100      IF( iom_use('emp_oce' ) )  CALL iom_put( "emp_oce"  , emp_oce(:,:) )   !emp over ocean (taking into account the snow blown away from the ice) 
     101      IF( iom_use('emp_ice' ) )  CALL iom_put( "emp_ice"  , emp_ice(:,:) )   !emp over ice   (taking into account the snow blown away from the ice) 
     102 
     103      ! velocity 
    106104      IF ( iom_use( "uice_ipa" ) .OR. iom_use( "vice_ipa" ) .OR. iom_use( "icevel" ) ) THEN  
    107105         DO jj = 2 , jpjm1 
    108106            DO ji = 2 , jpim1 
    109                z2da(ji,jj)  = (  u_ice(ji,jj) * umask(ji,jj,1) + u_ice(ji-1,jj) * umask(ji-1,jj,1) ) * 0.5_wp 
    110                z2db(ji,jj)  = (  v_ice(ji,jj) * vmask(ji,jj,1) + v_ice(ji,jj-1) * vmask(ji,jj-1,1) ) * 0.5_wp 
     107               z2da  = ( u_ice(ji,jj) * umask(ji,jj,1) + u_ice(ji-1,jj) * umask(ji-1,jj,1) ) * 0.5_wp 
     108               z2db  = ( v_ice(ji,jj) * vmask(ji,jj,1) + v_ice(ji,jj-1) * vmask(ji,jj-1,1) ) * 0.5_wp 
     109               z2d(ji,jj) = SQRT( z2da * z2da + z2db * z2db ) 
    111110           END DO 
    112111         END DO 
    113          CALL lbc_lnk( z2da, 'T', -1. ) 
    114          CALL lbc_lnk( z2db, 'T', -1. ) 
    115          CALL iom_put( "uice_ipa"     , z2da             )       ! ice velocity u component 
    116          CALL iom_put( "vice_ipa"     , z2db             )       ! ice velocity v component 
    117          DO jj = 1, jpj                                  
    118             DO ji = 1, jpi 
    119                z2d(ji,jj)  = SQRT( z2da(ji,jj) * z2da(ji,jj) + z2db(ji,jj) * z2db(ji,jj) )  
    120             END DO 
    121          END DO 
    122          CALL iom_put( "icevel"       , z2d              )       ! ice velocity module 
     112         CALL lbc_lnk( z2d, 'T', 1. ) 
     113         CALL iom_put( "uice_ipa"     , u_ice      )       ! ice velocity u component 
     114         CALL iom_put( "vice_ipa"     , v_ice      )       ! ice velocity v component 
     115         CALL iom_put( "icevel"       , z2d        )       ! ice velocity module 
    123116      ENDIF 
    124117      ! 
    125       IF ( iom_use( "miceage" ) ) THEN  
    126          z2d(:,:) = 0.e0 
    127          DO jl = 1, jpl 
    128             DO jj = 1, jpj 
    129                DO ji = 1, jpi 
    130                   rswitch    = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.1 ) ) 
    131                   z2d(ji,jj) = z2d(ji,jj) + rswitch * oa_i(ji,jj,jl) / MAX( at_i(ji,jj), 0.1 ) 
    132                END DO 
    133             END DO 
    134          END DO 
    135          CALL iom_put( "miceage"     , z2d * z1_365      )        ! mean ice age 
    136       ENDIF 
    137  
    138       IF ( iom_use( "micet" ) ) THEN  
    139          DO jj = 1, jpj 
    140             DO ji = 1, jpi 
    141                z2d(ji,jj) = ( tm_i(ji,jj) - rt0 ) * zswi(ji,jj) 
    142             END DO 
    143          END DO 
    144          CALL iom_put( "micet"       , z2d               )        ! mean ice temperature 
    145       ENDIF 
     118      IF ( iom_use( "miceage" ) )       CALL iom_put( "miceage"     , om_i * zswi * z1_365   )  ! mean ice age 
     119      IF ( iom_use( "icethic_cea" ) )   CALL iom_put( "icethic_cea" , htm_i * zswi           )  ! ice thickness mean 
     120      IF ( iom_use( "snowthic_cea" ) )  CALL iom_put( "snowthic_cea", htm_s * zswi           )  ! snow thickness mean 
     121      IF ( iom_use( "micet" ) )         CALL iom_put( "micet"       , ( tm_i  - rt0 ) * zswi )  ! ice mean    temperature 
     122      IF ( iom_use( "icest" ) )         CALL iom_put( "icest"       , ( tm_su - rt0 ) * zswi )  ! ice surface temperature 
     123      IF ( iom_use( "icecolf" ) )       CALL iom_put( "icecolf"     , hicol                  )  ! frazil ice collection thickness 
    146124      ! 
    147       IF ( iom_use( "icest" ) ) THEN  
    148          z2d(:,:) = 0.e0 
    149          DO jl = 1, jpl 
    150             DO jj = 1, jpj 
    151                DO ji = 1, jpi 
    152                   z2d(ji,jj) = z2d(ji,jj) + zswi(ji,jj) * ( t_su(ji,jj,jl) - rt0 ) * a_i(ji,jj,jl) / MAX( at_i(ji,jj) , epsi06 ) 
    153                END DO 
    154             END DO 
    155          END DO 
    156          CALL iom_put( "icest"       , z2d              )        ! ice surface temperature 
    157       ENDIF 
    158  
    159       IF ( iom_use( "icecolf" ) ) THEN  
    160          DO jj = 1, jpj 
    161             DO ji = 1, jpi 
    162                rswitch  = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) ) ) 
    163                z2d(ji,jj) = hicol(ji,jj) * rswitch 
    164             END DO 
    165          END DO 
    166          CALL iom_put( "icecolf"     , z2d              )        ! frazil ice collection thickness 
    167       ENDIF 
    168  
    169125      CALL iom_put( "isst"        , sst_m               )        ! sea surface temperature 
    170126      CALL iom_put( "isss"        , sss_m               )        ! sea surface salinity 
    171       CALL iom_put( "iceconc"     , at_i                )        ! ice concentration 
    172       CALL iom_put( "icevolu"     , vt_i                )        ! ice volume = mean ice thickness over the cell 
    173       CALL iom_put( "icehc"       , et_i                )        ! ice total heat content 
    174       CALL iom_put( "isnowhc"     , et_s                )        ! snow total heat content 
    175       CALL iom_put( "ibrinv"      , bv_i * 100._wp      )        ! brine volume 
     127      CALL iom_put( "iceconc"     , at_i  * zswi        )        ! ice concentration 
     128      CALL iom_put( "icevolu"     , vt_i  * zswi        )        ! ice volume = mean ice thickness over the cell 
     129      CALL iom_put( "icehc"       , et_i  * zswi        )        ! ice total heat content 
     130      CALL iom_put( "isnowhc"     , et_s  * zswi        )        ! snow total heat content 
     131      CALL iom_put( "ibrinv"      , bvm_i * zswi * 100. )        ! brine volume 
    176132      CALL iom_put( "utau_ice"    , utau_ice            )        ! wind stress over ice along i-axis at I-point 
    177133      CALL iom_put( "vtau_ice"    , vtau_ice            )        ! wind stress over ice along j-axis at I-point 
    178134      CALL iom_put( "snowpre"     , sprecip * 86400.    )        ! snow precipitation  
    179       CALL iom_put( "micesalt"    , smt_i               )        ! mean ice salinity 
    180  
    181       CALL iom_put( "icestr"      , strength * 0.001    )        ! ice strength 
    182       CALL iom_put( "idive"       , divu_i * 1.0e8      )        ! divergence 
    183       CALL iom_put( "ishear"      , shear_i * 1.0e8     )        ! shear 
    184       CALL iom_put( "snowvol"     , vt_s                )        ! snow volume 
     135      CALL iom_put( "micesalt"    , smt_i   * zswi      )        ! mean ice salinity 
     136 
     137      CALL iom_put( "icestr"      , strength * zswi )    ! ice strength 
     138      CALL iom_put( "idive"       , divu_i * 1.0e8      )    ! divergence 
     139      CALL iom_put( "ishear"      , shear_i * 1.0e8     )    ! shear 
     140      CALL iom_put( "snowvol"     , vt_s   * zswi       )        ! snow volume 
    185141       
    186142      CALL iom_put( "icetrp"      , diag_trp_vi * rday  )        ! ice volume transport 
    … …  
    190146      CALL iom_put( "destrp"      , diag_trp_es         )        ! advected snw enthalpy (W/m2) 
    191147 
    192       CALL iom_put( "sfxbog"      , sfx_bog * rday      )        ! salt flux from brines 
    193       CALL iom_put( "sfxbom"      , sfx_bom * rday      )        ! salt flux from brines 
    194       CALL iom_put( "sfxsum"      , sfx_sum * rday      )        ! salt flux from brines 
    195       CALL iom_put( "sfxsni"      , sfx_sni * rday      )        ! salt flux from brines 
    196       CALL iom_put( "sfxopw"      , sfx_opw * rday      )        ! salt flux from brines 
     148      CALL iom_put( "sfxbog"      , sfx_bog * rday      )        ! salt flux from bottom growth 
     149      CALL iom_put( "sfxbom"      , sfx_bom * rday      )        ! salt flux from bottom melting 
     150      CALL iom_put( "sfxsum"      , sfx_sum * rday      )        ! salt flux from surface melting 
     151      CALL iom_put( "sfxsni"      , sfx_sni * rday      )        ! salt flux from snow ice formation 
     152      CALL iom_put( "sfxopw"      , sfx_opw * rday      )        ! salt flux from open water formation 
    197153      CALL iom_put( "sfxdyn"      , sfx_dyn * rday      )        ! salt flux from ridging rafting 
    198154      CALL iom_put( "sfxres"      , sfx_res * rday      )        ! salt flux from limupdate (resultant) 
    199155      CALL iom_put( "sfxbri"      , sfx_bri * rday      )        ! salt flux from brines 
     156      CALL iom_put( "sfxsub"      , sfx_sub * rday      )        ! salt flux from sublimation 
    200157      CALL iom_put( "sfx"         , sfx     * rday      )        ! total salt flux 
    201158 
    … …  
    209166      CALL iom_put( "vfxbom"     , wfx_bom * ztmp       )        ! bottom melt  
    210167      CALL iom_put( "vfxice"     , wfx_ice * ztmp       )        ! total ice growth/melt  
     168 
     169      IF ( iom_use( "vfxthin" ) ) THEN   ! ice production for open water + thin ice (<20cm) => comparable to observations   
     170         WHERE( htm_i(:,:) < 0.2 .AND. htm_i(:,:) > 0. ) ; z2d = wfx_bog 
     171         ELSEWHERE                                       ; z2d = 0._wp 
     172         END WHERE 
     173         CALL iom_put( "vfxthin", ( wfx_opw + z2d ) * ztmp ) 
     174      ENDIF 
     175 
     176      ztmp = rday / rhosn 
     177      CALL iom_put( "vfxspr"     , wfx_spr * ztmp       )        ! precip (snow) 
    211178      CALL iom_put( "vfxsnw"     , wfx_snw * ztmp       )        ! total snw growth/melt  
    212       CALL iom_put( "vfxsub"     , wfx_sub * ztmp       )        ! sublimation (snow)  
    213       CALL iom_put( "vfxspr"     , wfx_spr * ztmp       )        ! precip (snow) 
    214        
     179      CALL iom_put( "vfxsub"     , wfx_sub * ztmp       )        ! sublimation (snow/ice)  
     180      CALL iom_put( "vfxsub_err" , wfx_err_sub * ztmp   )        ! "excess" of sublimation sent to ocean       
     181  
    215182      CALL iom_put( "afxtot"     , afx_tot * rday       )        ! concentration tendency (total) 
    216183      CALL iom_put( "afxdyn"     , afx_dyn * rday       )        ! concentration tendency (dynamics) 
    … …  
    232199      CALL iom_put ('hfxdif'     , hfx_dif(:,:)         )   !   
    233200      CALL iom_put ('hfxopw'     , hfx_opw(:,:)         )   !   
    234       CALL iom_put ('hfxtur'     , fhtur(:,:) * SUM(a_i_b(:,:,:), dim=3) ) ! turbulent heat flux at ice base  
     201      CALL iom_put ('hfxtur'     , fhtur(:,:) * SUM( a_i_b(:,:,:), dim=3 ) ) ! turbulent heat flux at ice base  
    235202      CALL iom_put ('hfxdhc'     , diag_heat(:,:)       )   ! Heat content variation in snow and ice  
    236203      CALL iom_put ('hfxspr'     , hfx_spr(:,:)         )   ! Heat content of snow precip  
     204 
    237205       
    238206      !-------------------------------- 
    239207      ! Output values for each category 
    240208      !-------------------------------- 
    241       CALL iom_put( "iceconc_cat"      , a_i         )        ! area for categories 
    242       CALL iom_put( "icethic_cat"      , ht_i        )        ! thickness for categories 
    243       CALL iom_put( "snowthic_cat"     , ht_s        )        ! snow depth for categories 
    244       CALL iom_put( "salinity_cat"     , sm_i        )        ! salinity for categories 
    245  
     209      IF ( iom_use( "iceconc_cat"  ) )  CALL iom_put( "iceconc_cat"      , a_i   * zswi2   )        ! area for categories 
     210      IF ( iom_use( "icethic_cat"  ) )  CALL iom_put( "icethic_cat"      , ht_i  * zswi2   )        ! thickness for categories 
     211      IF ( iom_use( "snowthic_cat" ) )  CALL iom_put( "snowthic_cat"     , ht_s  * zswi2   )        ! snow depth for categories 
     212      IF ( iom_use( "salinity_cat" ) )  CALL iom_put( "salinity_cat"     , sm_i  * zswi2   )        ! salinity for categories 
    246213      ! ice temperature 
    247       IF ( iom_use( "icetemp_cat" ) ) THEN  
    248          zt_i(:,:,:) = SUM( t_i(:,:,:,:), dim=3 ) * r1_nlay_i 
    249          CALL iom_put( "icetemp_cat"   , zt_i - rt0  ) 
    250       ENDIF 
    251        
     214      IF ( iom_use( "icetemp_cat"  ) )  CALL iom_put( "icetemp_cat", ( SUM( t_i(:,:,:,:), dim=3 ) * r1_nlay_i - rt0 ) * zswi2 ) 
    252215      ! snow temperature 
    253       IF ( iom_use( "snwtemp_cat" ) ) THEN  
    254          zt_s(:,:,:) = SUM( t_s(:,:,:,:), dim=3 ) * r1_nlay_s 
    255          CALL iom_put( "snwtemp_cat"   , zt_s - rt0  ) 
    256       ENDIF 
    257  
    258       ! Compute ice age 
    259       IF ( iom_use( "iceage_cat" ) ) THEN  
    260          DO jl = 1, jpl  
    261             DO jj = 1, jpj 
    262                DO ji = 1, jpi 
    263                   rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.1 ) ) 
    264                   rswitch = rswitch * MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - 0.1 ) ) 
    265                   zoi(ji,jj,jl) = oa_i(ji,jj,jl)  / MAX( a_i(ji,jj,jl) , 0.1 ) * rswitch 
    266                END DO 
    267             END DO 
    268          END DO 
    269          CALL iom_put( "iceage_cat"   , zoi * z1_365 )        ! ice age for categories 
    270       ENDIF 
    271  
    272       ! Compute brine volume 
    273       IF ( iom_use( "brinevol_cat" ) ) THEN  
    274          zei(:,:,:) = 0._wp 
    275          DO jl = 1, jpl  
    276             DO jk = 1, nlay_i 
    277                DO jj = 1, jpj 
    278                   DO ji = 1, jpi 
    279                      rswitch = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 
    280                      zei(ji,jj,jl) = zei(ji,jj,jl) + 100.0 *  & 
    281                         ( - tmut * s_i(ji,jj,jk,jl) / MIN( ( t_i(ji,jj,jk,jl) - rt0 ), - epsi06 ) ) * & 
    282                         rswitch * r1_nlay_i 
    283                   END DO 
    284                END DO 
    285             END DO 
    286          END DO 
    287          CALL iom_put( "brinevol_cat"     , zei      )        ! brine volume for categories 
    288       ENDIF 
     216      IF ( iom_use( "snwtemp_cat"  ) )  CALL iom_put( "snwtemp_cat", ( SUM( t_s(:,:,:,:), dim=3 ) * r1_nlay_s - rt0 ) * zswi2 ) 
     217      ! ice age 
     218      IF ( iom_use( "iceage_cat"   ) )  CALL iom_put( "iceage_cat" , o_i * zswi2 * z1_365 ) 
     219      ! brine volume 
     220      IF ( iom_use( "brinevol_cat" ) )  CALL iom_put( "brinevol_cat", bv_i * 100. * zswi2 ) 
    289221 
    290222      !     !  Create an output files (output.lim.abort.nc) if S < 0 or u > 20 m/s 
    … …  
    292224      !     not yet implemented 
    293225       
    294       CALL wrk_dealloc( jpi, jpj, jpl, zoi, zei, zt_i, zt_s ) 
    295       CALL wrk_dealloc( jpi, jpj     , z2d, zswi, z2da, z2db ) 
     226      CALL wrk_dealloc( jpi, jpj, jpl, zswi2 ) 
     227      CALL wrk_dealloc( jpi, jpj     , z2d, zswi ) 
    296228 
    297229      IF( nn_timing == 1 )  CALL timing_stop('limwri') 
    298230       
    299231   END SUBROUTINE lim_wri 
    300 #endif 
    301232 
    302233  
    … …  
    311242      !! 
    312243      !! History : 
    313       !!   4.1  !  2013-06  (C. Rousset) 
     244      !!   4.0  !  2013-06  (C. Rousset) 
    314245      !!---------------------------------------------------------------------- 
    315       INTEGER, INTENT( in ) ::   kt               ! ocean time-step index) 
    316       INTEGER, INTENT( in ) ::   kid , kh_i        
     246      INTEGER, INTENT( in )   ::   kt               ! ocean time-step index) 
     247      INTEGER, INTENT( in )   ::   kid , kh_i 
     248      INTEGER                 ::   nz_i, jl 
     249      REAL(wp), DIMENSION(jpl) :: jcat 
    317250      !!---------------------------------------------------------------------- 
    318  
    319       CALL histdef( kid, "iicethic", "Ice thickness"           , "m"      ,   & 
    320       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    321       CALL histdef( kid, "iiceconc", "Ice concentration"       , "%"      ,   & 
    322       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    323       CALL histdef( kid, "iicetemp", "Ice temperature"         , "C"      ,   & 
    324       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    325       CALL histdef( kid, "iicevelu", "i-Ice speed (I-point)"   , "m/s"    ,   & 
    326       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    327       CALL histdef( kid, "iicevelv", "j-Ice speed (I-point)"   , "m/s"    ,   & 
    328       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
    329       CALL histdef( kid, "iicestru", "i-Wind stress over ice (I-pt)", "Pa",   & 
    330       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    331       CALL histdef( kid, "iicestrv", "j-Wind stress over ice (I-pt)", "Pa",   & 
    332       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
    333       CALL histdef( kid, "iicesflx", "Solar flux over ocean"     , "w/m2" ,   & 
    334       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
    335       CALL histdef( kid, "iicenflx", "Non-solar flux over ocean" , "w/m2" ,   & 
     251      DO jl = 1, jpl 
     252         jcat(jl) = REAL(jl) 
     253      ENDDO 
     254       
     255      CALL histvert( kid, "ncatice", "Ice Categories","", jpl, jcat, nz_i, "up") 
     256 
     257      CALL histdef( kid, "sithic", "Ice thickness"           , "m"      ,   & 
     258      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     259      CALL histdef( kid, "siconc", "Ice concentration"       , "%"      ,   & 
     260      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     261      CALL histdef( kid, "sitemp", "Ice temperature"         , "C"      ,   & 
     262      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     263      CALL histdef( kid, "sivelu", "i-Ice speed "            , "m/s"    ,   & 
     264      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     265      CALL histdef( kid, "sivelv", "j-Ice speed "            , "m/s"    ,   & 
     266      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
     267      CALL histdef( kid, "sistru", "i-Wind stress over ice " , "Pa"     ,   & 
     268      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     269      CALL histdef( kid, "sistrv", "j-Wind stress over ice " , "Pa"     ,   & 
     270      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
     271      CALL histdef( kid, "sisflx", "Solar flux over ocean"     , "w/m2" ,   & 
     272      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
     273      CALL histdef( kid, "sinflx", "Non-solar flux over ocean" , "w/m2" ,   & 
    336274      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    337275      CALL histdef( kid, "isnowpre", "Snow precipitation"      , "kg/m2/s",   & 
    338276      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
    339       CALL histdef( kid, "iicesali", "Ice salinity"            , "PSU"    ,   & 
    340       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
    341       CALL histdef( kid, "iicevolu", "Ice volume"              , "m"      ,   & 
    342       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
    343       CALL histdef( kid, "iicedive", "Ice divergence"          , "10-8s-1",   & 
    344       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
    345       CALL histdef( kid, "iicebopr", "Ice bottom production"   , "m/s"    ,   & 
    346       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    347       CALL histdef( kid, "iicedypr", "Ice dynamic production"  , "m/s"    ,   & 
    348       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    349       CALL histdef( kid, "iicelapr", "Ice open water prod"     , "m/s"    ,   & 
     277      CALL histdef( kid, "sisali", "Ice salinity"            , "PSU"    ,   & 
     278      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
     279      CALL histdef( kid, "sivolu", "Ice volume"              , "m"      ,   & 
     280      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
     281      CALL histdef( kid, "sidive", "Ice divergence"          , "10-8s-1",   & 
     282      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )  
     283 
     284      CALL histdef( kid, "vfxbog", "Ice bottom production"   , "m/s"    ,   & 
     285      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     286      CALL histdef( kid, "vfxdyn", "Ice dynamic production"  , "m/s"    ,   & 
     287      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     288      CALL histdef( kid, "vfxopw", "Ice open water prod"     , "m/s"    ,   & 
    350289      &       jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    351       CALL histdef( kid, "iicesipr", "Snow ice production "    , "m/s"    ,   & 
    352       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    353       CALL histdef( kid, "iicerepr", "Ice prod from limupdate" , "m/s"    ,   & 
    354       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    355       CALL histdef( kid, "iicebome", "Ice bottom melt"         , "m/s"    ,   & 
    356       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    357       CALL histdef( kid, "iicesume", "Ice surface melt"        , "m/s"    ,   & 
    358       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    359       CALL histdef( kid, "iisfxdyn", "Salt flux from dynmics"  , ""       ,   & 
    360       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
    361       CALL histdef( kid, "iisfxres", "Salt flux from limupdate", ""       ,   & 
    362       &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     290      CALL histdef( kid, "vfxsni", "Snow ice production "    , "m/s"    ,   & 
     291      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     292      CALL histdef( kid, "vfxres", "Ice prod from limupdate" , "m/s"    ,   & 
     293      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     294      CALL histdef( kid, "vfxbom", "Ice bottom melt"         , "m/s"    ,   & 
     295      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     296      CALL histdef( kid, "vfxsum", "Ice surface melt"        , "m/s"    ,   & 
     297      &      jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
     298 
     299      CALL histdef( kid, "sithicat", "Ice thickness"         , "m"      ,   & 
     300      &      jpi, jpj, kh_i, jpl, 1, jpl, nz_i, 32, "inst(x)", rdt, rdt ) 
     301      CALL histdef( kid, "siconcat", "Ice concentration"     , "%"      ,   & 
     302      &      jpi, jpj, kh_i, jpl, 1, jpl, nz_i, 32, "inst(x)", rdt, rdt ) 
     303      CALL histdef( kid, "sisalcat", "Ice salinity"           , ""      ,   & 
     304      &      jpi, jpj, kh_i, jpl, 1, jpl, nz_i, 32, "inst(x)", rdt, rdt ) 
     305      CALL histdef( kid, "sitemcat", "Ice temperature"       , "C"      ,   & 
     306      &      jpi, jpj, kh_i, jpl, 1, jpl, nz_i, 32, "inst(x)", rdt, rdt ) 
     307      CALL histdef( kid, "snthicat", "Snw thickness"         , "m"      ,   & 
     308      &      jpi, jpj, kh_i, jpl, 1, jpl, nz_i, 32, "inst(x)", rdt, rdt ) 
     309      CALL histdef( kid, "sntemcat", "Snw temperature"       , "C"      ,   & 
     310      &      jpi, jpj, kh_i, jpl, 1, jpl, nz_i, 32, "inst(x)", rdt, rdt ) 
    363311 
    364312      CALL histend( kid, snc4set )   ! end of the file definition 
    365313 
    366       CALL histwrite( kid, "iicethic", kt, icethi        , jpi*jpj, (/1/) )     
    367       CALL histwrite( kid, "iiceconc", kt, at_i          , jpi*jpj, (/1/) ) 
    368       CALL histwrite( kid, "iicetemp", kt, tm_i - rt0    , jpi*jpj, (/1/) ) 
    369       CALL histwrite( kid, "iicevelu", kt, u_ice          , jpi*jpj, (/1/) ) 
    370       CALL histwrite( kid, "iicevelv", kt, v_ice          , jpi*jpj, (/1/) ) 
    371       CALL histwrite( kid, "iicestru", kt, utau_ice       , jpi*jpj, (/1/) ) 
    372       CALL histwrite( kid, "iicestrv", kt, vtau_ice       , jpi*jpj, (/1/) ) 
    373       CALL histwrite( kid, "iicesflx", kt, qsr , jpi*jpj, (/1/) ) 
    374       CALL histwrite( kid, "iicenflx", kt, qns , jpi*jpj, (/1/) ) 
     314      CALL histwrite( kid, "sithic", kt, htm_i         , jpi*jpj, (/1/) )     
     315      CALL histwrite( kid, "siconc", kt, at_i          , jpi*jpj, (/1/) ) 
     316      CALL histwrite( kid, "sitemp", kt, tm_i - rt0    , jpi*jpj, (/1/) ) 
     317      CALL histwrite( kid, "sivelu", kt, u_ice          , jpi*jpj, (/1/) ) 
     318      CALL histwrite( kid, "sivelv", kt, v_ice          , jpi*jpj, (/1/) ) 
     319      CALL histwrite( kid, "sistru", kt, utau_ice       , jpi*jpj, (/1/) ) 
     320      CALL histwrite( kid, "sistrv", kt, vtau_ice       , jpi*jpj, (/1/) ) 
     321      CALL histwrite( kid, "sisflx", kt, qsr , jpi*jpj, (/1/) ) 
     322      CALL histwrite( kid, "sinflx", kt, qns , jpi*jpj, (/1/) ) 
    375323      CALL histwrite( kid, "isnowpre", kt, sprecip        , jpi*jpj, (/1/) ) 
    376       CALL histwrite( kid, "iicesali", kt, smt_i          , jpi*jpj, (/1/) ) 
    377       CALL histwrite( kid, "iicevolu", kt, vt_i           , jpi*jpj, (/1/) ) 
    378       CALL histwrite( kid, "iicedive", kt, divu_i*1.0e8   , jpi*jpj, (/1/) ) 
    379  
    380       CALL histwrite( kid, "iicebopr", kt, wfx_bog        , jpi*jpj, (/1/) ) 
    381       CALL histwrite( kid, "iicedypr", kt, wfx_dyn        , jpi*jpj, (/1/) ) 
    382       CALL histwrite( kid, "iicelapr", kt, wfx_opw        , jpi*jpj, (/1/) ) 
    383       CALL histwrite( kid, "iicesipr", kt, wfx_sni        , jpi*jpj, (/1/) ) 
    384       CALL histwrite( kid, "iicerepr", kt, wfx_res        , jpi*jpj, (/1/) ) 
    385       CALL histwrite( kid, "iicebome", kt, wfx_bom        , jpi*jpj, (/1/) ) 
    386       CALL histwrite( kid, "iicesume", kt, wfx_sum        , jpi*jpj, (/1/) ) 
    387       CALL histwrite( kid, "iisfxdyn", kt, sfx_dyn        , jpi*jpj, (/1/) ) 
    388       CALL histwrite( kid, "iisfxres", kt, sfx_res        , jpi*jpj, (/1/) ) 
     324      CALL histwrite( kid, "sisali", kt, smt_i          , jpi*jpj, (/1/) ) 
     325      CALL histwrite( kid, "sivolu", kt, vt_i           , jpi*jpj, (/1/) ) 
     326      CALL histwrite( kid, "sidive", kt, divu_i*1.0e8   , jpi*jpj, (/1/) ) 
     327 
     328      CALL histwrite( kid, "vfxbog", kt, wfx_bog        , jpi*jpj, (/1/) ) 
     329      CALL histwrite( kid, "vfxdyn", kt, wfx_dyn        , jpi*jpj, (/1/) ) 
     330      CALL histwrite( kid, "vfxopw", kt, wfx_opw        , jpi*jpj, (/1/) ) 
     331      CALL histwrite( kid, "vfxsni", kt, wfx_sni        , jpi*jpj, (/1/) ) 
     332      CALL histwrite( kid, "vfxres", kt, wfx_res        , jpi*jpj, (/1/) ) 
     333      CALL histwrite( kid, "vfxbom", kt, wfx_bom        , jpi*jpj, (/1/) ) 
     334      CALL histwrite( kid, "vfxsum", kt, wfx_sum        , jpi*jpj, (/1/) ) 
     335 
     336      CALL histwrite( kid, "sithicat", kt, ht_i        , jpi*jpj*jpl, (/1/) )     
     337      CALL histwrite( kid, "siconcat", kt, a_i         , jpi*jpj*jpl, (/1/) )     
     338      CALL histwrite( kid, "sisalcat", kt, sm_i        , jpi*jpj*jpl, (/1/) )     
     339      CALL histwrite( kid, "sitemcat", kt, tm_i - rt0  , jpi*jpj*jpl, (/1/) )     
     340      CALL histwrite( kid, "snthicat", kt, ht_s        , jpi*jpj*jpl, (/1/) )     
     341      CALL histwrite( kid, "sntemcat", kt, tm_su - rt0 , jpi*jpj*jpl, (/1/) )     
    389342 
    390343      ! Close the file 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90

    r6772 r7256  
    4747   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qns_ice_1d   
    4848   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   t_bo_1d      
     49   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   rn_amax_1d 
    4950 
    5051   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_sum_1d 
    … …  
    8586   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_res_1d   
    8687 
     88   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_sub_1d 
     89 
    8790   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sprecip_1d    !: <==> the 2D  sprecip 
    8891   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   frld_1d       !: <==> the 2D  frld 
    … …  
    9396   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   evap_ice_1d   !: <==> the 2D  evap_ice 
    9497   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qprec_ice_1d  !: <==> the 2D  qprec_ice 
     98   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qevap_ice_1d  !: <==> the 3D  qevap_ice 
    9599   !                                                     ! to reintegrate longwave flux inside the ice thermodynamics 
    96100   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   i0            !: fraction of radiation transmitted to the ice 
    … …  
    109113   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_s_tot      !: Snow accretion/ablation        [m] 
    110114   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_surf     !: Ice surface accretion/ablation [m] 
     115   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_sub      !: Ice surface sublimation [m] 
    111116   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_bott     !: Ice bottom accretion/ablation  [m] 
    112117   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_snowice    !: Snow ice formation             [m of ice] 
    … …  
    146151         &      hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) ,    &  
    147152         &      hfx_dif_1d(jpij) , hfx_opw_1d(jpij) ,                      & 
     153         &      rn_amax_1d(jpij) ,                                         & 
    148154         &      hfx_thd_1d(jpij) , hfx_spr_1d(jpij) ,                      & 
    149155         &      hfx_snw_1d(jpij) , hfx_sub_1d(jpij) , hfx_err_1d(jpij) ,   & 
    … …  
    155161         &      wfx_sum_1d(jpij)  , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) ,  & 
    156162         &      dqns_ice_1d(jpij) , evap_ice_1d (jpij),                                         & 
    157          &      qprec_ice_1d(jpij), i0         (jpij) ,                                         &   
     163         &      qprec_ice_1d(jpij), qevap_ice_1d(jpij), i0         (jpij) ,                     &   
    158164         &      sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij),  & 
    159          &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) ,                     & 
     165         &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij),  & 
    160166         &      dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) ,                     &      
    161167         &      dsm_i_si_1d(jpij) , hicol_1d    (jpij)                     , STAT=ierr(2) ) 
    … …  
    163169      ALLOCATE( t_su_1d   (jpij) , a_i_1d   (jpij) , ht_i_1d  (jpij) ,    &    
    164170         &      ht_s_1d   (jpij) , fc_su    (jpij) , fc_bo_i  (jpij) ,    &     
    165          &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_bott(jpij) ,    &     
    166          &      dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
     171         &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_sub (jpij) ,    &     
     172         &      dh_i_bott (jpij) ,dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
    167173         &      t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) ,  &             
    168174         &      q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) ,                        & 
Note: See TracChangeset for help on using the changeset viewer.